[MLton] cvs commit: eliminated the distinction between integers and words
Stephen Weeks
sweeks@mlton.org
Fri, 30 Apr 2004 17:49:50 -0700
sweeks 04/04/30 17:49:49
Modified: basis-library/integer embed-int.sml int.sml integer.sig
basis-library/misc primitive.sml
include c-chunk.h
mlton/ast int-size.fun int-size.sig word-size.fun
word-size.sig
mlton/atoms atoms.fun atoms.sig const.fun const.sig
hash-type.fun hash-type.sig prim.fun prim.sig
sources.cm type-ops.fun type-ops.sig word-x.fun
word-x.sig
mlton/backend backend.fun backend.sig limit-check.fun
machine.fun machine.sig packed-representation.fun
rep-type.fun rep-type.sig representation.fun
representation.sig rssa.fun rssa.sig
ssa-to-rssa.fun ssa-to-rssa.sig switch.fun
mlton/closure-convert closure-convert.fun
mlton/codegen/c-codegen c-codegen.fun c-codegen.sig
mlton/codegen/x86-codegen x86-codegen.fun x86-codegen.sig
x86-mlton.fun x86-mlton.sig x86-translate.fun
mlton/defunctorize defunctorize.fun
mlton/elaborate const-type.sig elaborate-core.fun
elaborate.fun type-env.fun type-env.sig
mlton/main compile.fun lookup-constant.fun main.sml
mlton/match-compile match-compile.fun match-compile.sig
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/xml monomorphise.fun polyvariance.fun shrink.fun
simplify-types.fun type-check.fun xml-tree.fun
xml-tree.sig
runtime Makefile types.h
runtime/basis/Int Word64.c quot.c
Removed: runtime/basis/Int Int64.c addOverflow.c mulOverflow.c
subOverflow.c
Log:
MAIL eliminated the distinction between integers and words
Eliminated the distinction between integers and words from all ILs.
Now, there are only words. Integers are replaced by words immediately
after front end type checking. There are no longer any integer
primitives; instead, there are signed and unsigned versions of word
primitives (when a distinction needs to be made). This simplified
constant folding, as well as makes all the ILs and optimizer passes
slightly simpler because there's one less thing to worry about. It
also makes the codegens simpler, because they have one less kind of
constant to worry about (there was some pretty messy code in the
x86-codegen for integer constants that is now gone).
The names of many word and integer primitives in the basis library
primitive.sml has changed. Likewise, so have the names of these
primitives in the C codegen and runtime.
Moved the code that checks whether a codegen implements a primitive
from SsaToRssa into each of the codegens. The backend (and SsaToRssa)
now takes "cogegenImplementsPrim" as a parameter. This let me clean
up x86-mlton.fun in the x86 codegen, because the code for testing
whether a prim is implemented is separated from the code for
implementing the prim.
Fixed a bug in the SSA shrinker that could cause a label to be called
with the wrong number of arguments. The problem was in the code that
tried to simplify a case expression if all branches went to the same
label. It forgot to check that the label took no arguments.
Improved the implementation of weird-size integers, implementing the
coercion from big to small using a single comparison.
Revision Changes Path
1.3 +16 -21 mlton/basis-library/integer/embed-int.sml
Index: embed-int.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/embed-int.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- embed-int.sml 25 Apr 2004 06:55:43 -0000 1.2
+++ embed-int.sml 1 May 2004 00:49:32 -0000 1.3
@@ -16,35 +16,30 @@
open Small
- val shift = Word.fromInt (Int.- (valOf Big.precision, Small.precision'))
-
- val toBig: Small.int -> Big.int =
- fn s => Big.~>> (Big.<< (Small.toBig s, shift), shift)
+ val shift = Word.fromInt (Int.- (valOf Big.precision, precision'))
+
+ val extend: Big.int -> Big.int =
+ fn i => Big.~>> (Big.<< (i, shift), shift)
+
+ val toBig: Small.int -> Big.int = extend o Small.toBig
val precision = SOME precision'
- val maxIntBig =
- Big.fromLarge
- (IntInf.- (LargeInt.<< (1, Word.fromInt (Int.- (precision', 1))),
- 1))
+ val maxIntBig = Big.>> (Big.fromInt ~1, Word.+ (shift, 0w1))
val minIntBig = Big.- (Big.~ maxIntBig, Big.fromInt 1)
+ val mask = Big.>> (Big.fromInt ~1, shift)
+
fun fromBig (i: Big.int): int =
- if Big.< (i, Big.fromInt 0)
- then
- if Big.<= (minIntBig, i)
- then
- fromBigUnsafe
- (Big.- (i,
- Big.<< (Big.fromInt ~1,
- Word.fromInt Small.precision')))
- else raise Overflow
- else
- if Big.<= (i, maxIntBig)
- then fromBigUnsafe i
+ let
+ val i' = Big.andb (i, mask)
+ in
+ if i = extend i'
+ then fromBigUnsafe i'
else raise Overflow
-
+ end
+
val maxInt = SOME (fromBig maxIntBig)
val minInt = SOME (fromBig minIntBig)
1.3 +1 -1 mlton/basis-library/integer/int.sml
Index: int.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/int.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- int.sml 16 Feb 2004 22:43:19 -0000 1.2
+++ int.sml 1 May 2004 00:49:32 -0000 1.3
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
1.8 +5 -2 mlton/basis-library/integer/integer.sig
Index: integer.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/integer.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- integer.sig 25 Apr 2004 06:55:43 -0000 1.7
+++ integer.sig 1 May 2004 00:49:32 -0000 1.8
@@ -36,10 +36,12 @@
include PRE_INTEGER
val << : int * Word.word -> int
+ val >> : int * Word.word -> int
val ~>> : int * Word.word -> int
val *? : int * int -> int
val +? : int * int -> int
val -? : int * int -> int
+ val andb : int * int -> int
val maxInt' : int
val minInt' : int
val precision' : Int.int
@@ -76,14 +78,15 @@
include INTEGER
val << : int * Word.word -> int
+ val >> : int * Word.word -> int
val ~>> : int * Word.word -> int
val *? : int * int -> int
val +? : int * int -> int
val -? : int * int -> int
val ~? : int -> int
- val precision' : Int.int
+ val andb : int * int -> int
val maxInt' : int
val minInt' : int
-
val power: {base: int, exp: int} -> int
+ val precision' : Int.int
end
1.111 +287 -271 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.110
retrieving revision 1.111
diff -u -r1.110 -r1.111
--- primitive.sml 28 Apr 2004 00:48:52 -0000 1.110
+++ primitive.sml 1 May 2004 00:49:33 -0000 1.111
@@ -183,20 +183,21 @@
structure Char =
struct
- val op < = _prim "Word8_lt": char * char -> bool;
- val op <= = _prim "Word8_le": char * char -> bool;
- val op > = _prim "Word8_gt": char * char -> bool;
- val op >= = _prim "Word8_ge": char * char -> bool;
- val chr = _prim "Int32_toWord8": int -> char;
- val ord = _prim "Word8_toInt32": char -> int;
- val toWord8 = _prim "Char_toWord8": char -> Word8.word;
+ val op < = _prim "WordU8_lt": char * char -> bool;
+ val op <= = _prim "WordU8_le": char * char -> bool;
+ val op > = _prim "WordU8_gt": char * char -> bool;
+ val op >= = _prim "WordU8_ge": char * char -> bool;
+ val chr = _prim "WordS32_toWord8": int -> char;
+ val ord = _prim "WordU8_toWord32": char -> int;
+ val toWord8 = _prim "WordU8_toWord8": char -> Word8.word;
end
structure CommandLine =
struct
val argc = fn () => _import "CommandLine_argc": int;
val argv = fn () => _import "CommandLine_argv": cstringArray;
- val commandName = fn () => _import "CommandLine_commandName": cstring;
+ val commandName =
+ fn () => _import "CommandLine_commandName": cstring;
end
structure Date =
@@ -287,8 +288,10 @@
structure IEEEReal =
struct
- val getRoundingMode = _import "IEEEReal_getRoundingMode": unit -> int;
- val setRoundingMode = _import "IEEEReal_setRoundingMode": int -> unit;
+ val getRoundingMode =
+ _import "IEEEReal_getRoundingMode": unit -> int;
+ val setRoundingMode =
+ _import "IEEEReal_setRoundingMode": int -> unit;
end
structure Int8 =
@@ -299,36 +302,38 @@
val maxInt' : int = 0x7f
val minInt' : int = ~0x80
- val *? = _prim "Int8_mul": int * int -> int;
+ val *? = _prim "WordS8_mul": int * int -> int;
val * =
if detectOverflow
- then _prim "Int8_mulCheck": int * int -> int;
+ then _prim "WordS8_mulCheck": int * int -> int;
else *?
- val +? = _prim "Int8_add": int * int -> int;
+ val +? = _prim "Word8_add": int * int -> int;
val + =
if detectOverflow
- then _prim "Int8_addCheck": int * int -> int;
+ then _prim "WordS8_addCheck": int * int -> int;
else +?
- val -? = _prim "Int8_sub": int * int -> int;
+ val -? = _prim "Word8_sub": int * int -> int;
val - =
if detectOverflow
- then _prim "Int8_subCheck": int * int -> int;
+ then _prim "WordS8_subCheck": int * int -> int;
else -?
- val op < = _prim "Int8_lt": int * int -> bool;
- val op <= = _prim "Int8_le": int * int -> bool;
- val op > = _prim "Int8_gt": int * int -> bool;
- val op >= = _prim "Int8_ge": int * int -> bool;
- val quot = _prim "Int8_quot": int * int -> int;
- val rem = _prim "Int8_rem": int * int -> int;
- val << = _prim "Int8_lshift": int * Word.word -> int;
- val ~>> = _prim "Int8_arshift": int * Word.word -> int;
- val ~? = _prim "Int8_neg": int -> int;
+ val op < = _prim "WordS8_lt": int * int -> bool;
+ val op <= = _prim "WordS8_le": int * int -> bool;
+ val op > = _prim "WordS8_gt": int * int -> bool;
+ val op >= = _prim "WordS8_ge": int * int -> bool;
+ val quot = _prim "WordS8_quot": int * int -> int;
+ val rem = _prim "WordS8_rem": int * int -> int;
+ val << = _prim "Word8_lshift": int * Word.word -> int;
+ val >> = _prim "WordU8_rshift": int * Word.word -> int;
+ val ~>> = _prim "WordS8_rshift": int * Word.word -> int;
+ val ~? = _prim "Word8_neg": int -> int;
val ~ =
if detectOverflow
- then _prim "Int8_negCheck": int -> int;
+ then _prim "Word8_negCheck": int -> int;
else ~?
- val fromInt = _prim "Int32_toInt8": Int.int -> int;
- val toInt = _prim "Int8_toInt32": int -> Int.int;
+ val andb = _prim "Word8_andb": int * int -> int;
+ val fromInt = _prim "WordS32_toWord8": Int.int -> int;
+ val toInt = _prim "WordS8_toWord32": int -> Int.int;
end
structure Int16 =
@@ -339,260 +344,262 @@
val maxInt' : int = 0x7fff
val minInt' : int = ~0x8000
- val *? = _prim "Int16_mul": int * int -> int;
+ val *? = _prim "WordS16_mul": int * int -> int;
val * =
if detectOverflow
- then _prim "Int16_mulCheck": int * int -> int;
+ then _prim "WordS16_mulCheck": int * int -> int;
else *?
- val +? = _prim "Int16_add": int * int -> int;
+ val +? = _prim "Word16_add": int * int -> int;
val + =
if detectOverflow
- then _prim "Int16_addCheck": int * int -> int;
+ then _prim "WordS16_addCheck": int * int -> int;
else +?
- val -? = _prim "Int16_sub": int * int -> int;
+ val -? = _prim "Word16_sub": int * int -> int;
val - =
if detectOverflow
- then _prim "Int16_subCheck": int * int -> int;
+ then _prim "WordS16_subCheck": int * int -> int;
else -?
- val op < = _prim "Int16_lt": int * int -> bool;
- val op <= = _prim "Int16_le": int * int -> bool;
- val op > = _prim "Int16_gt": int * int -> bool;
- val op >= = _prim "Int16_ge": int * int -> bool;
- val quot = _prim "Int16_quot": int * int -> int;
- val rem = _prim "Int16_rem": int * int -> int;
- val << = _prim "Int16_lshift": int * Word.word -> int;
- val ~>> = _prim "Int16_arshift": int * Word.word -> int;
- val ~? = _prim "Int16_neg": int -> int;
+ val op < = _prim "WordS16_lt": int * int -> bool;
+ val op <= = _prim "WordS16_le": int * int -> bool;
+ val op > = _prim "WordS16_gt": int * int -> bool;
+ val op >= = _prim "WordS16_ge": int * int -> bool;
+ val quot = _prim "WordS16_quot": int * int -> int;
+ val rem = _prim "WordS16_rem": int * int -> int;
+ val << = _prim "Word16_lshift": int * Word.word -> int;
+ val >> = _prim "WordU16_rshift": int * Word.word -> int;
+ val ~>> = _prim "WordS16_rshift": int * Word.word -> int;
+ val ~? = _prim "Word16_neg": int -> int;
val ~ =
if detectOverflow
- then _prim "Int16_negCheck": int -> int;
+ then _prim "Word16_negCheck": int -> int;
else ~?
- val fromInt = _prim "Int32_toInt16": Int.int -> int;
- val toInt = _prim "Int16_toInt32": int -> Int.int;
+ val andb = _prim "Word16_andb": int * int -> int;
+ val fromInt = _prim "WordS32_toWord16": Int.int -> int;
+ val toInt = _prim "WordS16_toWord32": int -> Int.int;
end
structure Int2 =
struct
type big = Int8.int
type int = int2
- val fromBigUnsafe = _prim "Int8_toInt2": big -> int;
+ val fromBigUnsafe = _prim "WordU8_toWord2": big -> int;
val precision' = 2
- val toBig = _prim "Int2_toInt8": int -> big;
+ val toBig = _prim "WordU2_toWord8": int -> big;
end
structure Int3 =
struct
type big = Int8.int
type int = int3
- val fromBigUnsafe = _prim "Int8_toInt3": big -> int;
+ val fromBigUnsafe = _prim "WordU8_toWord3": big -> int;
val precision' = 3
- val toBig = _prim "Int3_toInt8": int -> big;
+ val toBig = _prim "WordU3_toWord8": int -> big;
end
structure Int4 =
struct
type big = Int8.int
type int = int4
- val fromBigUnsafe = _prim "Int8_toInt4": big -> int;
+ val fromBigUnsafe = _prim "WordU8_toWord4": big -> int;
val precision' = 4
- val toBig = _prim "Int4_toInt8": int -> big;
+ val toBig = _prim "WordU4_toWord8": int -> big;
end
structure Int5 =
struct
type big = Int8.int
type int = int5
- val fromBigUnsafe = _prim "Int8_toInt5": big -> int;
+ val fromBigUnsafe = _prim "WordU8_toWord5": big -> int;
val precision' = 5
- val toBig = _prim "Int5_toInt8": int -> big;
+ val toBig = _prim "WordU5_toWord8": int -> big;
end
structure Int6 =
struct
type big = Int8.int
type int = int6
- val fromBigUnsafe = _prim "Int8_toInt6": big -> int;
+ val fromBigUnsafe = _prim "WordU8_toWord6": big -> int;
val precision' = 6
- val toBig = _prim "Int6_toInt8": int -> big;
+ val toBig = _prim "WordU6_toWord8": int -> big;
end
structure Int7 =
struct
type big = Int8.int
type int = int7
- val fromBigUnsafe = _prim "Int8_toInt7": big -> int;
+ val fromBigUnsafe = _prim "WordU8_toWord7": big -> int;
val precision' = 7
- val toBig = _prim "Int7_toInt8": int -> big;
+ val toBig = _prim "WordU7_toWord8": int -> big;
end
structure Int9 =
struct
type big = Int16.int
type int = int9
- val fromBigUnsafe = _prim "Int16_toInt9": big -> int;
+ val fromBigUnsafe = _prim "WordU16_toWord9": big -> int;
val precision' = 9
- val toBig = _prim "Int9_toInt16": int -> big;
+ val toBig = _prim "WordU9_toWord16": int -> big;
end
structure Int10 =
struct
type big = Int16.int
type int = int10
- val fromBigUnsafe = _prim "Int16_toInt10": big -> int;
+ val fromBigUnsafe = _prim "WordU16_toWord10": big -> int;
val precision' = 10
- val toBig = _prim "Int10_toInt16": int -> big;
+ val toBig = _prim "WordU10_toWord16": int -> big;
end
structure Int11 =
struct
type big = Int16.int
type int = int11
- val fromBigUnsafe = _prim "Int16_toInt11": big -> int;
+ val fromBigUnsafe = _prim "WordU16_toWord11": big -> int;
val precision' = 11
- val toBig = _prim "Int11_toInt16": int -> big;
+ val toBig = _prim "WordU11_toWord16": int -> big;
end
structure Int12 =
struct
type big = Int16.int
type int = int12
- val fromBigUnsafe = _prim "Int16_toInt12": big -> int;
+ val fromBigUnsafe = _prim "WordU16_toWord12": big -> int;
val precision' = 12
- val toBig = _prim "Int12_toInt16": int -> big;
+ val toBig = _prim "WordU12_toWord16": int -> big;
end
structure Int13 =
struct
type big = Int16.int
type int = int13
- val fromBigUnsafe = _prim "Int16_toInt13": big -> int;
+ val fromBigUnsafe = _prim "WordU16_toWord13": big -> int;
val precision' = 13
- val toBig = _prim "Int13_toInt16": int -> big;
+ val toBig = _prim "WordU13_toWord16": int -> big;
end
structure Int14 =
struct
type big = Int16.int
type int = int14
- val fromBigUnsafe = _prim "Int16_toInt14": big -> int;
+ val fromBigUnsafe = _prim "WordU16_toWord14": big -> int;
val precision' = 14
- val toBig = _prim "Int14_toInt16": int -> big;
+ val toBig = _prim "WordU14_toWord16": int -> big;
end
structure Int15 =
struct
type big = Int16.int
type int = int15
- val fromBigUnsafe = _prim "Int16_toInt15": big -> int;
+ val fromBigUnsafe = _prim "WordU16_toWord15": big -> int;
val precision' = 15
- val toBig = _prim "Int15_toInt16": int -> big;
+ val toBig = _prim "WordU15_toWord16": int -> big;
end
structure Int17 =
struct
type big = Int32.int
type int = int17
- val fromBigUnsafe = _prim "Int32_toInt17": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord17": big -> int;
val precision' = 17
- val toBig = _prim "Int17_toInt32": int -> big;
+ val toBig = _prim "WordU17_toWord32": int -> big;
end
structure Int18 =
struct
type big = Int32.int
type int = int18
- val fromBigUnsafe = _prim "Int32_toInt18": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord18": big -> int;
val precision' = 18
- val toBig = _prim "Int18_toInt32": int -> big;
+ val toBig = _prim "WordU18_toWord32": int -> big;
end
structure Int19 =
struct
type big = Int32.int
type int = int19
- val fromBigUnsafe = _prim "Int32_toInt19": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord19": big -> int;
val precision' = 19
- val toBig = _prim "Int19_toInt32": int -> big;
+ val toBig = _prim "WordU19_toWord32": int -> big;
end
structure Int20 =
struct
type big = Int32.int
type int = int20
- val fromBigUnsafe = _prim "Int32_toInt20": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord20": big -> int;
val precision' = 20
- val toBig = _prim "Int20_toInt32": int -> big;
+ val toBig = _prim "WordU20_toWord32": int -> big;
end
structure Int21 =
struct
type big = Int32.int
type int = int21
- val fromBigUnsafe = _prim "Int32_toInt21": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord21": big -> int;
val precision' = 21
- val toBig = _prim "Int21_toInt32": int -> big;
+ val toBig = _prim "WordU21_toWord32": int -> big;
end
structure Int22 =
struct
type big = Int32.int
type int = int22
- val fromBigUnsafe = _prim "Int32_toInt22": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord22": big -> int;
val precision' = 22
- val toBig = _prim "Int22_toInt32": int -> big;
+ val toBig = _prim "WordU22_toWord32": int -> big;
end
structure Int23 =
struct
type big = Int32.int
type int = int23
- val fromBigUnsafe = _prim "Int32_toInt23": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord23": big -> int;
val precision' = 23
- val toBig = _prim "Int23_toInt32": int -> big;
+ val toBig = _prim "WordU23_toWord32": int -> big;
end
structure Int24 =
struct
type big = Int32.int
type int = int24
- val fromBigUnsafe = _prim "Int32_toInt24": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord24": big -> int;
val precision' = 24
- val toBig = _prim "Int24_toInt32": int -> big;
+ val toBig = _prim "WordU24_toWord32": int -> big;
end
structure Int25 =
struct
type big = Int32.int
type int = int25
- val fromBigUnsafe = _prim "Int32_toInt25": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord25": big -> int;
val precision' = 25
- val toBig = _prim "Int25_toInt32": int -> big;
+ val toBig = _prim "WordU25_toWord32": int -> big;
end
structure Int26 =
struct
type big = Int32.int
type int = int26
- val fromBigUnsafe = _prim "Int32_toInt26": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord26": big -> int;
val precision' = 26
- val toBig = _prim "Int26_toInt32": int -> big;
+ val toBig = _prim "WordU26_toWord32": int -> big;
end
structure Int27 =
struct
type big = Int32.int
type int = int27
- val fromBigUnsafe = _prim "Int32_toInt27": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord27": big -> int;
val precision' = 27
- val toBig = _prim "Int27_toInt32": int -> big;
+ val toBig = _prim "WordU27_toWord32": int -> big;
end
structure Int28 =
struct
type big = Int32.int
type int = int28
- val fromBigUnsafe = _prim "Int32_toInt28": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord28": big -> int;
val precision' = 28
- val toBig = _prim "Int28_toInt32": int -> big;
+ val toBig = _prim "WordU28_toWord32": int -> big;
end
structure Int29 =
struct
type big = Int32.int
type int = int29
- val fromBigUnsafe = _prim "Int32_toInt29": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord29": big -> int;
val precision' = 29
- val toBig = _prim "Int29_toInt32": int -> big;
+ val toBig = _prim "WordU29_toWord32": int -> big;
end
structure Int30 =
struct
type big = Int32.int
type int = int30
- val fromBigUnsafe = _prim "Int32_toInt30": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord30": big -> int;
val precision' = 30
- val toBig = _prim "Int30_toInt32": int -> big;
+ val toBig = _prim "WordU30_toWord32": int -> big;
end
structure Int31 =
struct
type big = Int32.int
type int = int31
- val fromBigUnsafe = _prim "Int32_toInt31": big -> int;
+ val fromBigUnsafe = _prim "WordU32_toWord31": big -> int;
val precision' = 31
- val toBig = _prim "Int31_toInt32": int -> big;
+ val toBig = _prim "WordU31_toWord32": int -> big;
end
structure Int32 =
struct
@@ -602,34 +609,36 @@
val maxInt' : int = 0x7fffffff
val minInt' : int = ~0x80000000
- val *? = _prim "Int32_mul": int * int -> int;
+ val *? = _prim "WordS32_mul": int * int -> int;
val * =
if detectOverflow
- then _prim "Int32_mulCheck": int * int -> int;
+ then _prim "WordS32_mulCheck": int * int -> int;
else *?
- val +? = _prim "Int32_add": int * int -> int;
+ val +? = _prim "Word32_add": int * int -> int;
val + =
if detectOverflow
- then _prim "Int32_addCheck": int * int -> int;
+ then _prim "WordS32_addCheck": int * int -> int;
else +?
- val -? = _prim "Int32_sub": int * int -> int;
+ val -? = _prim "Word32_sub": int * int -> int;
val - =
if detectOverflow
- then _prim "Int32_subCheck": int * int -> int;
+ then _prim "WordS32_subCheck": int * int -> int;
else -?
- val op < = _prim "Int32_lt": int * int -> bool;
- val op <= = _prim "Int32_le": int * int -> bool;
- val op > = _prim "Int32_gt": int * int -> bool;
- val op >= = _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_lshift": int * Word.word -> int;
- val ~>> = _prim "Int32_arshift": int * Word.word -> int;
- val ~? = _prim "Int32_neg": int -> int;
+ val op < = _prim "WordS32_lt": int * int -> bool;
+ val op <= = _prim "WordS32_le": int * int -> bool;
+ val op > = _prim "WordS32_gt": int * int -> bool;
+ val op >= = _prim "WordS32_ge": int * int -> bool;
+ val quot = _prim "WordS32_quot": int * int -> int;
+ val rem = _prim "WordS32_rem": int * int -> int;
+ val << = _prim "Word32_lshift": int * Word.word -> int;
+ val >> = _prim "WordU32_rshift": int * Word.word -> int;
+ val ~>> = _prim "WordS32_rshift": int * Word.word -> int;
+ val ~? = _prim "Word32_neg": int -> int;
val ~ =
if detectOverflow
- then _prim "Int32_negCheck": int -> int;
+ then _prim "Word32_negCheck": int -> int;
else ~?
+ val andb = _prim "Word32_andb": int * int -> int;
val fromInt : int -> int = fn x => x
val toInt : int -> int = fn x => x
end
@@ -644,38 +653,47 @@
val maxInt' : int = 0x7FFFFFFFFFFFFFFF
val minInt' : int = ~0x8000000000000000
- val *? = _prim "Int64_mul": int * int -> int;
- val +? = _prim "Int64_add": int * int -> int;
+ val *? = _prim "WordS64_mul": int * int -> int;
+ val +? = _prim "Word64_add": int * int -> int;
val + =
if detectOverflow
- then _prim "Int64_addCheck": int * int -> int;
+ then _prim "WordS64_addCheck": int * int -> int;
else +?
- val -? = _prim "Int64_sub": int * int -> int;
+ val -? = _prim "Word64_sub": int * int -> int;
val - =
if detectOverflow
- then _prim "Int64_subCheck": int * int -> int;
+ then _prim "WordS64_subCheck": int * int -> int;
else -?
- val op < = _prim "Int64_lt": int * int -> bool;
- val op <= = _prim "Int64_le": int * int -> bool;
- val op > = _prim "Int64_gt": int * int -> bool;
- val op >= = _prim "Int64_ge": int * int -> bool;
- val << = _prim "Int64_lshift": int * Word.word -> int;
- val _ = << (* quell unused warning *)
- val ~>> = _prim "Int64_arshift": int * Word.word -> int;
- val _ = ~>> (* quell unused warning *)
- val quot = _prim "Int64_quot": int * int -> int;
- val rem = _prim "Int64_rem": int * int -> int;
- val ~? = _prim "Int64_neg": int -> int;
+ val op < = _prim "WordS64_lt": int * int -> bool;
+ val op <= = _prim "WordS64_le": int * int -> bool;
+ val op > = _prim "WordS64_gt": int * int -> bool;
+ val op >= = _prim "WordS64_ge": int * int -> bool;
+ val << = _prim "Word64_lshift": int * Word.word -> int;
+ val >> = _prim "WordU64_rshift": int * Word.word -> int;
+ val ~>> = _prim "WordS64_rshift": int * Word.word -> int;
+ val quot = _prim "WordS64_quot": int * int -> int;
+ val rem = _prim "WordS64_rem": int * int -> int;
+ val ~? = _prim "Word64_neg": int -> int;
val ~ =
if detectOverflow
- then _prim "Int64_negCheck": int -> int;
+ then _prim "Word64_negCheck": int -> int;
else ~?
- val fromInt = _prim "Int32_toInt64": Int.int -> int;
- val fromWord = _prim "Word32_toInt64": word -> int;
- val toInt = _prim "Int64_toInt32": int -> Int.int;
- val toWord = _prim "Int64_toWord32": int -> word;
-
+ val andb = _prim "Word64_andb": int * int -> int;
+ val fromInt = _prim "WordS32_toWord64": Int.int -> int;
+ val fromWord = _prim "WordU32_toWord64": word -> int;
+ val toInt = _prim "WordU64_toWord32": int -> Int.int;
+ val toWord = _prim "WordU64_toWord32": int -> word;
val * = fn _ => raise Fail "Int64.* unimplemented"
+ (* quell unused warnings *)
+ val () =
+ let
+ val _ = <<
+ val _ = >>
+ val _ = ~>>
+ val _ = andb
+ in
+ ()
+ end
end
structure Array =
@@ -947,9 +965,6 @@
struct
open Pointer
-(* val fromWord = _prim "Word_toPointer": word -> t; *)
-(* val toWord = _prim "Pointer_toWord": t -> word; *)
-
val fromWord = fn w => w
val toWord = fn w => w
@@ -957,10 +972,10 @@
fun isNull p = p = null
- val getInt8 = _prim "Pointer_getInt8": t * int -> Int8.int;
- val getInt16 = _prim "Pointer_getInt16": t * int -> Int16.int;
- val getInt32 = _prim "Pointer_getInt32": t * int -> Int32.int;
- val getInt64 = _prim "Pointer_getInt64": t * int -> Int64.int;
+ val getInt8 = _prim "Pointer_getWord8": t * int -> Int8.int;
+ val getInt16 = _prim "Pointer_getWord16": t * int -> Int16.int;
+ val getInt32 = _prim "Pointer_getWord32": t * int -> Int32.int;
+ val getInt64 = _prim "Pointer_getWord64": t * int -> Int64.int;
val getPointer = _prim "Pointer_getPointer": t * int -> 'a;
val getReal32 = _prim "Pointer_getReal32": t * int -> Real32.real;
val getReal64 = _prim "Pointer_getReal64": t * int -> Real64.real;
@@ -968,10 +983,13 @@
val getWord16 = _prim "Pointer_getWord16": t * int -> Word16.word;
val getWord32 = _prim "Pointer_getWord32": t * int -> Word32.word;
val getWord64 = _prim "Pointer_getWord64": t * int -> Word64.word;
- val setInt8 = _prim "Pointer_setInt8": t * int * Int8.int -> unit;
- val setInt16 = _prim "Pointer_setInt16": t * int * Int16.int -> unit;
- val setInt32 = _prim "Pointer_setInt32": t * int * Int32.int -> unit;
- val setInt64 = _prim "Pointer_setInt64": t * int * Int64.int -> unit;
+ val setInt8 = _prim "Pointer_setWord8": t * int * Int8.int -> unit;
+ val setInt16 =
+ _prim "Pointer_setWord16": t * int * Int16.int -> unit;
+ val setInt32 =
+ _prim "Pointer_setWord32": t * int * Int32.int -> unit;
+ val setInt64 =
+ _prim "Pointer_setWord64": t * int * Int64.int -> unit;
val setPointer = _prim "Pointer_setPointer": t * int * 'a -> unit;
val setReal32 =
_prim "Pointer_setReal32": t * int * Real32.real -> unit;
@@ -1031,7 +1049,7 @@
val frexp = _import "Real64_frexp": real * int ref -> real;
val gdtoa =
_import "Real64_gdtoa": real * int * int * int ref -> cstring;
- val fromInt = _prim "Int32_toReal64": int -> real;
+ val fromInt = _prim "WordS32_toReal64": int -> real;
val ldexp = _prim "Real64_ldexp": real * int -> real;
val maxFinite = _import "Real64_maxFinite": real;
val minNormalPos = _import "Real64_minNormalPos": real;
@@ -1041,7 +1059,7 @@
val round = _prim "Real64_round": real -> real;
val signBit = _import "Real64_signBit": real -> bool;
val strto = _import "Real64_strto": NullString.t -> real;
- val toInt = _prim "Real64_toInt32": real -> int;
+ val toInt = _prim "Real64_toWordS32": real -> int;
val ~ = _prim "Real64_neg": real -> real;
val fromLarge : real -> real = fn x => x
@@ -1108,7 +1126,7 @@
fromLarge (Real64.frexp (toLarge r, ir))
val gdtoa =
_import "Real32_gdtoa": real * int * int * int ref -> cstring;
- val fromInt = _prim "Int32_toReal32": int -> real;
+ val fromInt = _prim "WordS32_toReal32": int -> real;
val ldexp = _prim "Real32_ldexp": real * int -> real;
val maxFinite = _import "Real32_maxFinite": real;
val minNormalPos = _import "Real32_minNormalPos": real;
@@ -1116,7 +1134,7 @@
val modf = _import "Real32_modf": real * real ref -> real;
val signBit = _import "Real32_signBit": real -> bool;
val strto = _import "Real32_strto": NullString.t -> real;
- val toInt = _prim "Real32_toInt32": real -> int;
+ val toInt = _prim "Real32_toWordS32": real -> int;
val ~ = _prim "Real32_neg": real -> real;
end
@@ -1380,29 +1398,29 @@
val + = _prim "Word8_add": word * word -> word;
val andb = _prim "Word8_andb": word * word -> word;
- val ~>> = _prim "Word8_arshift": word * Word.word -> word;
- val div = _prim "Word8_div": word * word -> word;
- val fromInt = _prim "Int32_toWord8": int -> word;
- val fromLarge = _prim "Word64_toWord8": LargeWord.word -> word;
- val op >= = _prim "Word8_ge": word * word -> bool;
- val op > = _prim "Word8_gt" : word * word -> bool;
- val op <= = _prim "Word8_le": word * word -> bool;
+ val ~>> = _prim "WordS8_rshift": word * Word.word -> word;
+ val div = _prim "WordU8_quot": word * word -> word;
+ val fromInt = _prim "WordU32_toWord8": int -> word;
+ val fromLarge = _prim "WordU64_toWord8": LargeWord.word -> word;
+ val op >= = _prim "WordU8_ge": word * word -> bool;
+ val op > = _prim "WordU8_gt" : word * word -> bool;
+ val op <= = _prim "WordU8_le": word * word -> bool;
val << = _prim "Word8_lshift": word * Word.word -> word;
- val op < = _prim "Word8_lt" : word * word -> bool;
- val mod = _prim "Word8_mod": word * word -> word;
- val * = _prim "Word8_mul": word * word -> word;
+ val op < = _prim "WordU8_lt" : word * word -> bool;
+ val mod = _prim "WordU8_rem": word * word -> word;
+ val * = _prim "WordU8_mul": word * word -> word;
val ~ = _prim "Word8_neg": word -> word;
val notb = _prim "Word8_notb": word -> word;
val orb = _prim "Word8_orb": word * word -> word;
val rol = _prim "Word8_rol": word * Word.word -> word;
val ror = _prim "Word8_ror": word * Word.word -> word;
- val >> = _prim "Word8_rshift": word * Word.word -> word;
+ val >> = _prim "WordU8_rshift": word * Word.word -> word;
val - = _prim "Word8_sub": word * word -> word;
- val toChar = _prim "Word8_toChar": word -> char;
- val toInt = _prim "Word8_toInt32": word -> int;
- val toIntX = _prim "Word8_toInt32X": word -> int;
- val toLarge = _prim "Word8_toWord64": word -> LargeWord.word;
- val toLargeX = _prim "Word8_toWord64X": word -> LargeWord.word;
+ val toChar = _prim "WordU8_toWord8": word -> char;
+ val toInt = _prim "WordU8_toWord32": word -> int;
+ val toIntX = _prim "WordS8_toWord32": word -> int;
+ val toLarge = _prim "WordU8_toWord64": word -> LargeWord.word;
+ val toLargeX = _prim "WordS8_toWord64": word -> LargeWord.word;
val xorb = _prim "Word8_xorb": word * word -> word;
end
@@ -1434,26 +1452,26 @@
val + = _prim "Word16_add": word * word -> word;
val andb = _prim "Word16_andb": word * word -> word;
- val ~>> = _prim "Word16_arshift": word * Word.word -> word;
- val div = _prim "Word16_div": word * word -> word;
- val fromInt = _prim "Int32_toWord16": int -> word;
- val fromLarge = _prim "Word64_toWord16": LargeWord.word -> word;
- val op >= = _prim "Word16_ge": word * word -> bool;
- val op > = _prim "Word16_gt" : word * word -> bool;
- val op <= = _prim "Word16_le": word * word -> bool;
+ val ~>> = _prim "WordS16_rshift": word * Word.word -> word;
+ val div = _prim "WordU16_quot": word * word -> word;
+ val fromInt = _prim "WordU32_toWord16": int -> word;
+ val fromLarge = _prim "WordU64_toWord16": LargeWord.word -> word;
+ val op >= = _prim "WordU16_ge": word * word -> bool;
+ val op > = _prim "WordU16_gt" : word * word -> bool;
+ val op <= = _prim "WordU16_le": word * word -> bool;
val << = _prim "Word16_lshift": word * Word.word -> word;
- val op < = _prim "Word16_lt" : word * word -> bool;
- val mod = _prim "Word16_mod": word * word -> word;
- val * = _prim "Word16_mul": word * word -> word;
+ val op < = _prim "WordU16_lt" : word * word -> bool;
+ val mod = _prim "WordU16_rem": word * word -> word;
+ val * = _prim "WordU16_mul": word * word -> word;
val ~ = _prim "Word16_neg": word -> word;
val notb = _prim "Word16_notb": word -> word;
val orb = _prim "Word16_orb": word * word -> word;
- val >> = _prim "Word16_rshift": word * Word.word -> word;
+ val >> = _prim "WordU16_rshift": word * Word.word -> word;
val - = _prim "Word16_sub": word * word -> word;
- val toInt = _prim "Word16_toInt32": word -> int;
- val toIntX = _prim "Word16_toInt32X": word -> int;
- val toLarge = _prim "Word16_toWord64": word -> LargeWord.word;
- val toLargeX = _prim "Word16_toWord64X": word -> LargeWord.word;
+ val toInt = _prim "WordU16_toWord32": word -> int;
+ val toIntX = _prim "WordS16_toWord32": word -> int;
+ val toLarge = _prim "WordU16_toWord64": word -> LargeWord.word;
+ val toLargeX = _prim "WordS16_toWord64": word -> LargeWord.word;
val xorb = _prim "Word16_xorb": word * word -> word;
end
@@ -1463,31 +1481,29 @@
val wordSize: int = 32
val + = _prim "Word32_add": word * word -> word;
-(* val addCheck = _prim "Word32_addCheck": word * word -> word; *)
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 "Int32_toWord32": int -> word;
- val fromLarge = _prim "Word64_toWord32": LargeWord.word -> word;
- val op >= = _prim "Word32_ge": word * word -> bool;
- val op > = _prim "Word32_gt" : word * word -> bool;
- val op <= = _prim "Word32_le": word * word -> bool;
+ val ~>> = _prim "WordS32_rshift": word * word -> word;
+ val div = _prim "WordU32_quot": word * word -> word;
+ val fromInt = _prim "WordU32_toWord32": int -> word;
+ val fromLarge = _prim "WordU64_toWord32": LargeWord.word -> word;
+ val op >= = _prim "WordU32_ge": word * word -> bool;
+ val op > = _prim "WordU32_gt" : word * word -> bool;
+ val op <= = _prim "WordU32_le": word * word -> bool;
val << = _prim "Word32_lshift": word * word -> word;
- val op < = _prim "Word32_lt" : word * word -> bool;
- val mod = _prim "Word32_mod": word * word -> word;
- val * = _prim "Word32_mul": word * word -> word;
-(* val mulCheck = _prim "Word32_mulCheck": word * word -> word; *)
+ val op < = _prim "WordU32_lt" : word * word -> bool;
+ val mod = _prim "WordU32_rem": word * word -> word;
+ val * = _prim "WordU32_mul": word * word -> word;
val ~ = _prim "Word32_neg": word -> word;
val notb = _prim "Word32_notb": word -> word;
val orb = _prim "Word32_orb": word * word -> word;
val rol = _prim "Word32_rol": word * word -> word;
val ror = _prim "Word32_ror": word * word -> word;
- val >> = _prim "Word32_rshift": word * word -> word;
+ val >> = _prim "WordU32_rshift": word * word -> word;
val - = _prim "Word32_sub": word * word -> word;
- val toInt = _prim "Word32_toInt32": word -> int;
- val toIntX = _prim "Word32_toInt32X": word -> int;
- val toLarge = _prim "Word32_toWord64": word -> LargeWord.word;
- val toLargeX = _prim "Word32_toWord64X": word -> LargeWord.word;
+ val toInt = _prim "WordU32_toWord32": word -> int;
+ val toIntX = _prim "WordS32_toWord32": word -> int;
+ val toLarge = _prim "WordU32_toWord64": word -> LargeWord.word;
+ val toLargeX = _prim "WordS32_toWord64": word -> LargeWord.word;
val xorb = _prim "Word32_xorb": word * word -> word;
end
structure Word = Word32
@@ -1499,24 +1515,24 @@
val + = _prim "Word64_add": word * word -> word;
val andb = _prim "Word64_andb": word * word -> word;
- val ~>> = _prim "Word64_arshift": word * Word.word -> word;
- val div = _prim "Word64_div": word * word -> word;
- val fromInt = _prim "Int32_toWord64": int -> word;
+ val ~>> = _prim "WordS64_rshift": word * Word.word -> word;
+ val div = _prim "WordU64_quot": word * word -> word;
+ val fromInt = _prim "WordS32_toWord64": int -> word;
val fromLarge: LargeWord.word -> word = fn x => x
- val op >= = _prim "Word64_ge": word * word -> bool;
- val op > = _prim "Word64_gt" : word * word -> bool;
- val op <= = _prim "Word64_le": word * word -> bool;
+ val op >= = _prim "WordU64_ge": word * word -> bool;
+ val op > = _prim "WordU64_gt" : word * word -> bool;
+ val op <= = _prim "WordU64_le": word * word -> bool;
val << = _prim "Word64_lshift": word * Word.word -> word;
- val op < = _prim "Word64_lt" : word * word -> bool;
- val mod = _prim "Word64_mod": word * word -> word;
- val * = _prim "Word64_mul": word * word -> word;
+ val op < = _prim "WordU64_lt" : word * word -> bool;
+ val mod = _prim "WordU64_rem": word * word -> word;
+ val * = _prim "WordU64_mul": word * word -> word;
val ~ = _prim "Word64_neg": word -> word;
val notb = _prim "Word64_notb": word -> word;
val orb = _prim "Word64_orb": word * word -> word;
- val >> = _prim "Word64_rshift": word * Word.word -> word;
+ val >> = _prim "WordU64_rshift": word * Word.word -> word;
val - = _prim "Word64_sub": word * word -> word;
- val toInt = _prim "Word64_toInt32": word -> int;
- val toIntX = _prim "Word64_toInt32X": word -> int;
+ val toInt = _prim "WordU64_toWord32": word -> int;
+ val toIntX = _prim "WordU64_toWord32": word -> int;
val toLarge: word -> LargeWord.word = fn x => x
val toLargeX: word -> LargeWord.word = fn x => x
val xorb = _prim "Word64_xorb": word * word -> word;
@@ -1526,224 +1542,224 @@
struct
type big = Word8.word
type word = word2
- val fromBigUnsafe = _prim "Word8_toWord2": big -> word;
- val toBig = _prim "Word2_toWord8": word -> big;
+ val fromBigUnsafe = _prim "WordU8_toWord2": big -> word;
+ val toBig = _prim "WordU2_toWord8": word -> big;
val wordSize = 2
end
structure Word3 =
struct
type big = Word8.word
type word = word3
- val fromBigUnsafe = _prim "Word8_toWord3": big -> word;
- val toBig = _prim "Word3_toWord8": word -> big;
+ val fromBigUnsafe = _prim "WordU8_toWord3": big -> word;
+ val toBig = _prim "WordU3_toWord8": word -> big;
val wordSize = 3
end
structure Word4 =
struct
type big = Word8.word
type word = word4
- val fromBigUnsafe = _prim "Word8_toWord4": big -> word;
- val toBig = _prim "Word4_toWord8": word -> big;
+ val fromBigUnsafe = _prim "WordU8_toWord4": big -> word;
+ val toBig = _prim "WordU4_toWord8": word -> big;
val wordSize = 4
end
structure Word5 =
struct
type big = Word8.word
type word = word5
- val fromBigUnsafe = _prim "Word8_toWord5": big -> word;
- val toBig = _prim "Word5_toWord8": word -> big;
+ val fromBigUnsafe = _prim "WordU8_toWord5": big -> word;
+ val toBig = _prim "WordU5_toWord8": word -> big;
val wordSize = 5
end
structure Word6 =
struct
type big = Word8.word
type word = word6
- val fromBigUnsafe = _prim "Word8_toWord6": big -> word;
- val toBig = _prim "Word6_toWord8": word -> big;
+ val fromBigUnsafe = _prim "WordU8_toWord6": big -> word;
+ val toBig = _prim "WordU6_toWord8": word -> big;
val wordSize = 6
end
structure Word7 =
struct
type big = Word8.word
type word = word7
- val fromBigUnsafe = _prim "Word8_toWord7": big -> word;
- val toBig = _prim "Word7_toWord8": word -> big;
+ val fromBigUnsafe = _prim "WordU8_toWord7": big -> word;
+ val toBig = _prim "WordU7_toWord8": word -> big;
val wordSize = 7
end
structure Word9 =
struct
type big = Word16.word
type word = word9
- val fromBigUnsafe = _prim "Word16_toWord9": big -> word;
- val toBig = _prim "Word9_toWord16": word -> big;
+ val fromBigUnsafe = _prim "WordU16_toWord9": big -> word;
+ val toBig = _prim "WordU9_toWord16": word -> big;
val wordSize = 9
end
structure Word10 =
struct
type big = Word16.word
type word = word10
- val fromBigUnsafe = _prim "Word16_toWord10": big -> word;
- val toBig = _prim "Word10_toWord16": word -> big;
+ val fromBigUnsafe = _prim "WordU16_toWord10": big -> word;
+ val toBig = _prim "WordU10_toWord16": word -> big;
val wordSize = 10
end
structure Word11 =
struct
type big = Word16.word
type word = word11
- val fromBigUnsafe = _prim "Word16_toWord11": big -> word;
- val toBig = _prim "Word11_toWord16": word -> big;
+ val fromBigUnsafe = _prim "WordU16_toWord11": big -> word;
+ val toBig = _prim "WordU11_toWord16": word -> big;
val wordSize = 11
end
structure Word12 =
struct
type big = Word16.word
type word = word12
- val fromBigUnsafe = _prim "Word16_toWord12": big -> word;
- val toBig = _prim "Word12_toWord16": word -> big;
+ val fromBigUnsafe = _prim "WordU16_toWord12": big -> word;
+ val toBig = _prim "WordU12_toWord16": word -> big;
val wordSize = 12
end
structure Word13 =
struct
type big = Word16.word
type word = word13
- val fromBigUnsafe = _prim "Word16_toWord13": big -> word;
- val toBig = _prim "Word13_toWord16": word -> big;
+ val fromBigUnsafe = _prim "WordU16_toWord13": big -> word;
+ val toBig = _prim "WordU13_toWord16": word -> big;
val wordSize = 13
end
structure Word14 =
struct
type big = Word16.word
type word = word14
- val fromBigUnsafe = _prim "Word16_toWord14": big -> word;
- val toBig = _prim "Word14_toWord16": word -> big;
+ val fromBigUnsafe = _prim "WordU16_toWord14": big -> word;
+ val toBig = _prim "WordU14_toWord16": word -> big;
val wordSize = 14
end
structure Word15 =
struct
type big = Word16.word
type word = word15
- val fromBigUnsafe = _prim "Word16_toWord15": big -> word;
- val toBig = _prim "Word15_toWord16": word -> big;
+ val fromBigUnsafe = _prim "WordU16_toWord15": big -> word;
+ val toBig = _prim "WordU15_toWord16": word -> big;
val wordSize = 15
end
structure Word17 =
struct
type big = Word32.word
type word = word17
- val fromBigUnsafe = _prim "Word32_toWord17": big -> word;
- val toBig = _prim "Word17_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord17": big -> word;
+ val toBig = _prim "WordU17_toWord32": word -> big;
val wordSize = 17
end
structure Word18 =
struct
type big = Word32.word
type word = word18
- val fromBigUnsafe = _prim "Word32_toWord18": big -> word;
- val toBig = _prim "Word18_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord18": big -> word;
+ val toBig = _prim "WordU18_toWord32": word -> big;
val wordSize = 18
end
structure Word19 =
struct
type big = Word32.word
type word = word19
- val fromBigUnsafe = _prim "Word32_toWord19": big -> word;
- val toBig = _prim "Word19_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord19": big -> word;
+ val toBig = _prim "WordU19_toWord32": word -> big;
val wordSize = 19
end
structure Word20 =
struct
type big = Word32.word
type word = word20
- val fromBigUnsafe = _prim "Word32_toWord20": big -> word;
- val toBig = _prim "Word20_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord20": big -> word;
+ val toBig = _prim "WordU20_toWord32": word -> big;
val wordSize = 20
end
structure Word21 =
struct
type big = Word32.word
type word = word21
- val fromBigUnsafe = _prim "Word32_toWord21": big -> word;
- val toBig = _prim "Word21_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord21": big -> word;
+ val toBig = _prim "WordU21_toWord32": word -> big;
val wordSize = 21
end
structure Word22 =
struct
type big = Word32.word
type word = word22
- val fromBigUnsafe = _prim "Word32_toWord22": big -> word;
- val toBig = _prim "Word22_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord22": big -> word;
+ val toBig = _prim "WordU22_toWord32": word -> big;
val wordSize = 22
end
structure Word23 =
struct
type big = Word32.word
type word = word23
- val fromBigUnsafe = _prim "Word32_toWord23": big -> word;
- val toBig = _prim "Word23_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord23": big -> word;
+ val toBig = _prim "WordU23_toWord32": word -> big;
val wordSize = 23
end
structure Word24 =
struct
type big = Word32.word
type word = word24
- val fromBigUnsafe = _prim "Word32_toWord24": big -> word;
- val toBig = _prim "Word24_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord24": big -> word;
+ val toBig = _prim "WordU24_toWord32": word -> big;
val wordSize = 24
end
structure Word25 =
struct
type big = Word32.word
type word = word25
- val fromBigUnsafe = _prim "Word32_toWord25": big -> word;
- val toBig = _prim "Word25_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord25": big -> word;
+ val toBig = _prim "WordU25_toWord32": word -> big;
val wordSize = 25
end
structure Word26 =
struct
type big = Word32.word
type word = word26
- val fromBigUnsafe = _prim "Word32_toWord26": big -> word;
- val toBig = _prim "Word26_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord26": big -> word;
+ val toBig = _prim "WordU26_toWord32": word -> big;
val wordSize = 26
end
structure Word27 =
struct
type big = Word32.word
type word = word27
- val fromBigUnsafe = _prim "Word32_toWord27": big -> word;
- val toBig = _prim "Word27_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord27": big -> word;
+ val toBig = _prim "WordU27_toWord32": word -> big;
val wordSize = 27
end
structure Word28 =
struct
type big = Word32.word
type word = word28
- val fromBigUnsafe = _prim "Word32_toWord28": big -> word;
- val toBig = _prim "Word28_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord28": big -> word;
+ val toBig = _prim "WordU28_toWord32": word -> big;
val wordSize = 28
end
structure Word29 =
struct
type big = Word32.word
type word = word29
- val fromBigUnsafe = _prim "Word32_toWord29": big -> word;
- val toBig = _prim "Word29_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord29": big -> word;
+ val toBig = _prim "WordU29_toWord32": word -> big;
val wordSize = 29
end
structure Word30 =
struct
type big = Word32.word
type word = word30
- val fromBigUnsafe = _prim "Word32_toWord30": big -> word;
- val toBig = _prim "Word30_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord30": big -> word;
+ val toBig = _prim "WordU30_toWord32": word -> big;
val wordSize = 30
end
structure Word31 =
struct
type big = Word32.word
type word = word31
- val fromBigUnsafe = _prim "Word32_toWord31": big -> word;
- val toBig = _prim "Word31_toWord32": word -> big;
+ val fromBigUnsafe = _prim "WordU32_toWord31": big -> word;
+ val toBig = _prim "WordU31_toWord32": word -> big;
val wordSize = 31
end
1.25 +206 -275 mlton/include/c-chunk.h
Index: c-chunk.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-chunk.h,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- c-chunk.h 25 Apr 2004 22:02:48 -0000 1.24
+++ c-chunk.h 1 May 2004 00:49:33 -0000 1.25
@@ -195,229 +195,6 @@
} while (0)
/* ------------------------------------------------- */
-/* Int */
-/* ------------------------------------------------- */
-
-/* The default is to use INT_TEST. */
-#if (! defined (INT_NO_CHECK) && ! defined (INT_TEST))
-#define INT_TEST
-#endif
-
-#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
-#define Int_negCheck(dst, n, l) dst = -n
-#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 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, xW, cW, l) \
- do { \
- Int##size x = xW; \
- Int##size c = cW; \
- 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, nW, l) \
- do { \
- Int##size n = nW; \
- if (n == Int##size##_min) \
- goto l; \
- dst = -n; \
- } while (0)
-
-#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, cW, xW, l) \
- do { \
- Int##size c = cW; \
- Int##size x = xW; \
- 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, xW, cW, l) \
- do { \
- Int##size c = cW; \
- Int##size x = xW; \
- 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_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 > Word##size##_max - c) \
- goto l; \
- dst = x + c; \
- } while (0)
-#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 Word8_addCheck Word8_addCheckXC
-#define Word16_addCheck Word16_addCheckXC
-#define Word32_addCheck Word32_addCheckXC
-#define Word64_addCheck Word64_addCheckXC
-
-#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
-
-#define check(dst, n1, n2, l, f); \
- do { \
- int overflow; \
- dst = f (n1, n2, &overflow); \
- if (DEBUG_CCODEGEN) \
- fprintf (stderr, "%s:%d: " #f "(%d, %d) = %d\n", \
- __FILE__, __LINE__, n1, n2, dst); \
- if (overflow) { \
- if (DEBUG_CCODEGEN) \
- fprintf (stderr, "%s:%d: overflow\n", \
- __FILE__, __LINE__); \
- goto l; \
- } \
- } while (0)
-
-#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_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 (mul, *)
-#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
-
-
-/* ------------------------------------------------- */
/* Real */
/* ------------------------------------------------- */
@@ -551,10 +328,15 @@
(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 wordCmp(size, name, op) \
+ static inline Bool Word##size##_##name \
+ (Word##size w1, Word##size w2) { \
+ Bool res = w1 op w2; \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "%s = 0x%08x " #op " 0x%08x\n", \
+ res ? "true": "false", \
+ w1, w2); \
+ return w1 op w2; \
}
#define wordShift(size, name, op) \
static inline Word##size Word##size##_##name \
@@ -568,26 +350,31 @@
#define wordOps(size) \
wordBinary (size, add, +) \
wordBinary (size, andb, &) \
- wordBinary (size, div, /) \
- wordBinary (size, mod, %) \
- wordBinary (size, mul, *) \
+ wordBinary (S##size, mul, *) \
+ wordBinary (U##size, mul, *) \
wordBinary (size, orb, |) \
+ wordBinary (U##size, quot, /) \
+ wordBinary (U##size, rem, %) \
wordBinary (size, sub, -) \
wordBinary (size, xorb, ^) \
wordCmp (size, equal, ==) \
- wordCmp (size, ge, >=) \
- wordCmp (size, gt, >) \
- wordCmp (size, le, <=) \
- wordCmp (size, lt, <) \
+ wordCmp (S##size, ge, >=) \
+ wordCmp (U##size, ge, >=) \
+ wordCmp (S##size, gt, >) \
+ wordCmp (U##size, gt, >) \
+ wordCmp (S##size, le, <=) \
+ wordCmp (U##size, le, <=) \
+ wordCmp (S##size, lt, <) \
+ wordCmp (U##size, lt, <) \
wordShift (size, lshift, <<) \
- wordShift (size, rshift, >>) \
+ wordShift (U##size, rshift, >>) \
wordUnary (size, neg, -) \
wordUnary (size, notb, ~) \
- /* Word_arshift isn't ANSI C, because ANSI doesn't guarantee sign \
+ /* WordS_rshift 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 WordS##size##_rshift (WordS##size w, Word s) { \
+ return w >> s; \
} \
static inline Word##size Word##size##_rol (Word##size w1, Word w2) { \
return (w1 >> (size - w2)) | (w1 << w2); \
@@ -605,46 +392,190 @@
static inline t f##_to##t (f x) { \
return (t)x; \
}
-coerce (Int16, Real32)
-coerce (Int16, Real64)
-coerce (Int32, Real32)
-coerce (Int32, Real64)
-coerce (Int8, Real32)
-coerce (Int8, Real64)
-coerce (Real32, Int16)
-coerce (Real32, Int32)
-coerce (Real32, Int8)
-coerce (Real32, Real32)
coerce (Real32, Real64)
-coerce (Real64, Int16)
-coerce (Real64, Int32)
-coerce (Real64, Int8)
+coerce (Real32, WordS32)
coerce (Real64, Real32)
-coerce (Real64, Real64)
-coerce (Word16, Word32)
-coerce (Word16, Word64)
-coerce (Word16, Word8)
-coerce (Word32, Word16)
-coerce (Word32, Word64)
-coerce (Word32, Word8)
-coerce (Word64, Word16)
-coerce (Word64, Word32)
-coerce (Word64, Word8)
-coerce (Word8, Word16)
-coerce (Word8, Word32)
-coerce (Word8, Word64)
+coerce (Real64, WordS32)
+coerce (WordS16, Real32)
+coerce (WordS16, Real64)
+coerce (WordS16, Word32)
+coerce (WordS16, Word64)
+coerce (WordS32, Real32)
+coerce (WordS32, Real64)
+coerce (WordS32, Word64)
+coerce (WordS8, Real32)
+coerce (WordS8, Real64)
+coerce (WordS8, Word16)
+coerce (WordS8, Word32)
+coerce (WordS8, Word64)
+coerce (WordU16, Word32)
+coerce (WordU16, Word64)
+coerce (WordU16, Word8)
+coerce (WordU32, Word16)
+coerce (WordU32, Word64)
+coerce (WordU32, Word8)
+coerce (WordU64, Word16)
+coerce (WordU64, Word32)
+coerce (WordU64, Word8)
+coerce (WordU8, Word16)
+coerce (WordU8, Word32)
+coerce (WordU8, Word64)
#undef coerce
-#define coerceX(size, t) \
- static inline t Word##size##_to##t##X (Word##size x) { \
- return (t)(Int##size)x; \
- }
-coerceX (32, Word64)
-coerceX (16, Word64)
-coerceX (16, Word32)
-coerceX (8, Word64)
-coerceX (8, Word32)
-coerceX (8, Word16)
-#undef coerceX
+#define WordS8_max (WordS8)0x7F
+#define WordS8_min (WordS8)0x80
+#define WordS16_max (WordS16)0x7FFF
+#define WordS16_min (WordS16)0x8000
+#define WordS32_max (WordS32)0x7FFFFFFF
+#define WordS32_min (WordS32)0x80000000
+#define WordS64_max (WordS64)0x7FFFFFFFFFFFFFFF
+#define WordS64_min (WordS64)0x8000000000000000
+#define Word8_max (Word8)0xFF
+#define Word16_max (Word16)0xFFFF
+#define Word32_max (Word32)0xFFFFFFFF
+#define Word64_max (Word64)0xFFFFFFFFFFFFFFFF
+
+#define WordS_addCheckXC(size, dst, xW, cW, l) \
+ do { \
+ WordS##size x = xW; \
+ WordS##size c = cW; \
+ if (c >= 0) { \
+ if (x > WordS##size##_max - c) \
+ goto l; \
+ } else if (x < WordS##size##_min - c) \
+ goto l; \
+ dst = x + c; \
+ } while (0)
+#define WordS8_addCheckXC(dst, x, c, l) WordS_addCheckXC(8, dst, x, c, l)
+#define WordS16_addCheckXC(dst, x, c, l) WordS_addCheckXC(16, dst, x, c, l)
+#define WordS32_addCheckXC(dst, x, c, l) WordS_addCheckXC(32, dst, x, c, l)
+#define WordS64_addCheckXC(dst, x, c, l) WordS_addCheckXC(64, dst, x, c, l)
+
+#define WordS8_addCheckCX(dst, c, x, l) WordS8_addCheckXC(dst, x, c, l)
+#define WordS16_addCheckCX(dst, c, x, l) WordS16_addCheckXC(dst, x, c, l)
+#define WordS32_addCheckCX(dst, c, x, l) WordS32_addCheckXC(dst, x, c, l)
+#define WordS64_addCheckCX(dst, c, x, l) WordS64_addCheckXC(dst, x, c, l)
+
+#define WordS8_addCheck WordS8_addCheckXC
+#define WordS16_addCheck WordS16_addCheckXC
+#define WordS32_addCheck WordS32_addCheckXC
+#define WordS64_addCheck WordS64_addCheckXC
+
+#define WordS_negCheck(size, dst, nW, l) \
+ do { \
+ WordS##size n = nW; \
+ if (n == WordS##size##_min) \
+ goto l; \
+ dst = -n; \
+ } while (0)
+
+#define Word8_negCheck(dst, n, l) WordS_negCheck(8, dst, n, l)
+#define Word16_negCheck(dst, n, l) WordS_negCheck(16, dst, n, l)
+#define Word32_negCheck(dst, n, l) WordS_negCheck(32, dst, n, l)
+#define Word64_negCheck(dst, n, l) WordS_negCheck(64, dst, n, l)
+
+#define WordS_subCheckCX(size, dst, cW, xW, l) \
+ do { \
+ WordS##size c = cW; \
+ WordS##size x = xW; \
+ if (c >= 0) { \
+ if (x < c - WordS##size##_max) \
+ goto l; \
+ } else if (x > c - WordS##size##_min) \
+ goto l; \
+ dst = c - x; \
+ } while (0)
+#define WordS8_subCheckCX(dst, c, x, l) WordS_subCheckCX(8, dst, c, x, l)
+#define WordS16_subCheckCX(dst, c, x, l) WordS_subCheckCX(16, dst, c, x, l)
+#define WordS32_subCheckCX(dst, c, x, l) WordS_subCheckCX(32, dst, c, x, l)
+#define WordS64_subCheckCX(dst, c, x, l) WordS_subCheckCX(64, dst, c, x, l)
+
+#define WordS_subCheckXC(size, dst, xW, cW, l) \
+ do { \
+ WordS##size c = cW; \
+ WordS##size x = xW; \
+ if (c <= 0) { \
+ if (x > WordS##size##_max + c) \
+ goto l; \
+ } else if (x < WordS##size##_min + c) \
+ goto l; \
+ dst = x - c; \
+ } while (0)
+#define WordS8_subCheckXC(dst, c, x, l) WordS_subCheckXC(8, dst, c, x, l)
+#define WordS16_subCheckXC(dst, c, x, l) WordS_subCheckXC(16, dst, c, x, l)
+#define WordS32_subCheckXC(dst, c, x, l) WordS_subCheckXC(32, dst, c, x, l)
+#define WordS64_subCheckXC(dst, c, x, l) WordS_subCheckXC(64, dst, c, x, l)
+
+#define WordS8_subCheck WordS8_subCheckXC
+#define WordS16_subCheck WordS16_subCheckXC
+#define WordS32_subCheck WordS32_subCheckXC
+#define WordS64_subCheck WordS64_subCheckXC
+
+#define Word_addCheckXC(size, dst, x, c, l) \
+ do { \
+ if (x > Word##size##_max - c) \
+ goto l; \
+ dst = x + c; \
+ } while (0)
+#define WordU8_addCheckXC(dst, x, c, l) Word_addCheckXC(8, dst, x, c, l)
+#define WordU16_addCheckXC(dst, x, c, l) Word_addCheckXC(16, dst, x, c, l)
+#define WordU32_addCheckXC(dst, x, c, l) Word_addCheckXC(32, dst, x, c, l)
+#define WordU64_addCheckXC(dst, x, c, l) Word_addCheckXC(64, dst, x, c, l)
+#define WordU8_addCheckCX(dst, c, x, l) Word_addCheckXC(8, dst, x, c, l)
+#define WordU16_addCheckCX(dst, c, x, l) Word_addCheckXC(16, dst, x, c, l)
+#define WordU32_addCheckCX(dst, c, x, l) Word_addCheckXC(32, dst, x, c, l)
+#define WordU64_addCheckCX(dst, c, x, l) Word_addCheckXC(64, dst, x, c, l)
+
+#define WordU8_addCheck WordU8_addCheckXC
+#define WordU16_addCheck WordU16_addCheckXC
+#define WordU32_addCheck WordU32_addCheckXC
+#define WordU64_addCheck WordU64_addCheckXC
+
+#define mulOverflow(small, large) \
+ static inline Word##small Word##small##_##mulOverflow \
+ (Word##small x1, Word##small x2, Bool *overflow) { \
+ Word##large tmp; \
+ Word##small res; \
+ \
+ tmp = (Word##large)x1 * x2; \
+ res = tmp; \
+ *overflow = (tmp != res); \
+ return res; \
+ }
+mulOverflow(S8, S16)
+mulOverflow(S16, S32)
+mulOverflow(S32, S64)
+mulOverflow(U8, U16)
+mulOverflow(U16, U32)
+mulOverflow(U32, U64)
+#undef mulOverflow
+
+#define check(dst, n1, n2, l, f); \
+ do { \
+ int overflow; \
+ dst = f (n1, n2, &overflow); \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "%s:%d: " #f "(%d, %d) = %d\n", \
+ __FILE__, __LINE__, n1, n2, dst); \
+ if (overflow) { \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "%s:%d: overflow\n", \
+ __FILE__, __LINE__); \
+ goto l; \
+ } \
+ } while (0)
+
+#define WordS8_mulCheck(dst, n1, n2, l) \
+ check (dst, n1, n2, l, WordS8_mulOverflow)
+#define WordS16_mulCheck(dst, n1, n2, l) \
+ check (dst, n1, n2, l, WordS16_mulOverflow)
+#define WordS32_mulCheck(dst, n1, n2, l) \
+ check (dst, n1, n2, l, WordS32_mulOverflow)
+#define WordU8_mulCheck(dst, n1, n2, l) \
+ check (dst, n1, n2, l, WordU8_mulOverflow)
+#define WordU16_mulCheck(dst, n1, n2, l) \
+ check (dst, n1, n2, l, WordU16_mulOverflow)
+#define WordU32_mulCheck(dst, n1, n2, l) \
+ check (dst, n1, n2, l, WordU32_mulOverflow)
#endif /* #ifndef _C_CHUNK_H_ */
1.11 +0 -20 mlton/mlton/ast/int-size.fun
Index: int-size.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/int-size.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- int-size.fun 28 Apr 2004 03:17:04 -0000 1.10
+++ int-size.fun 1 May 2004 00:49:34 -0000 1.11
@@ -93,24 +93,4 @@
NONE => Error.bug "IntSize.prim"
| SOME p => p
-val range =
- memoize
- (fn s =>
- let
- val pow = IntInf.pow (2, Bits.toInt (bits s) - 1)
- in
- (~ pow, pow - 1)
- end)
-
-fun isInRange (s, i) =
- let
- val (min, max) = range s
- in
- min <= i andalso i <= max
- end
-
-val min = #1 o range
-
-val max = #2 o range
-
end
1.7 +0 -4 mlton/mlton/ast/int-size.sig
Index: int-size.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/int-size.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- int-size.sig 28 Apr 2004 03:17:04 -0000 1.6
+++ int-size.sig 1 May 2004 00:49:34 -0000 1.7
@@ -25,15 +25,11 @@
val default: t
val equals: t * t -> bool
val I : Bits.t -> 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 roundUpToPrim: t -> t
val toString: t -> string
end
1.11 +19 -1 mlton/mlton/ast/word-size.fun
Index: word-size.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/word-size.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- word-size.fun 28 Apr 2004 03:17:04 -0000 1.10
+++ word-size.fun 1 May 2004 00:49:34 -0000 1.11
@@ -82,7 +82,25 @@
fun cardinality s = IntInf.<< (1, Bits.toWord (bits s))
-fun max s = cardinality s - 1
+fun range (s, {signed}) =
+ if signed
+ then
+ let
+ val pow = IntInf.pow (2, Bits.toInt (bits s) - 1)
+ in
+ (~ pow, pow - 1)
+ end
+ else (0, cardinality s - 1)
+
+val min = #1 o range
+val max = #2 o range
+
+fun isInRange (s, i, sg) =
+ let
+ val (min, max) = range (s, sg)
+ in
+ min <= i andalso i <= max
+ end
datatype prim = W8 | W16 | W32 | W64
1.10 +3 -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.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- word-size.sig 28 Apr 2004 03:17:04 -0000 1.9
+++ word-size.sig 1 May 2004 00:49:34 -0000 1.10
@@ -27,8 +27,10 @@
val default: t
val equals: t * t -> bool
val fromBits: Bits.t -> t
+ val isInRange: t * IntInf.t * {signed: bool} -> bool
val layout: t -> Layout.t
- val max: t -> IntInf.t
+ val max: t * {signed: bool} -> IntInf.t
+ val min: t * {signed: bool} -> IntInf.t
val memoize: (t -> 'a) -> t -> 'a
val one: t
val pointer: unit -> t
1.18 +1 -4 mlton/mlton/atoms/atoms.fun
Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- atoms.fun 25 Apr 2004 06:55:43 -0000 1.17
+++ atoms.fun 1 May 2004 00:49:34 -0000 1.18
@@ -22,7 +22,6 @@
structure WordSize = WordSize)
structure Con = Con ()
structure CType = CType ()
- structure IntX = IntX (structure IntSize = IntSize)
structure RealX = RealX (structure RealSize = RealSize)
structure WordX = WordX (structure WordSize = WordSize)
structure Func =
@@ -35,15 +34,13 @@
open Func
fun newNoname () = newString "L"
end
- structure Const = Const (structure IntX = IntX
- structure RealX = RealX
+ structure Const = Const (structure RealX = RealX
structure WordX = WordX)
structure CFunction = CFunction ()
structure Prim = Prim (structure CFunction = CFunction
structure CType = CType
structure Con = Con
structure Const = Const
- structure IntSize = IntSize
structure RealSize = RealSize
structure WordSize = WordSize)
structure Ffi = Ffi (structure CFunction = CFunction
1.18 +1 -5 mlton/mlton/atoms/atoms.sig
Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- atoms.sig 25 Apr 2004 06:55:44 -0000 1.17
+++ atoms.sig 1 May 2004 00:49:34 -0000 1.18
@@ -28,7 +28,6 @@
structure Const: CONST
structure Ffi: FFI
structure Func: FUNC
- structure IntX: INT_X
structure Label: LABEL
structure Prim: PRIM
structure ProfileLabel: PROFILE_LABEL
@@ -46,8 +45,7 @@
sharing CType = Ffi.CType = Prim.CType
sharing Con = Prim.Con
sharing Const = Prim.Const
- sharing IntSize = IntX.IntSize = Prim.IntSize = Tycon.IntSize
- sharing IntX = Const.IntX
+ sharing IntSize = Tycon.IntSize
sharing RealSize = Prim.RealSize = RealX.RealSize = Tycon.RealSize
sharing RealX = Const.RealX
sharing SourceInfo = ProfileExp.SourceInfo
@@ -77,8 +75,6 @@
sharing Ffi = Atoms.Ffi
sharing Field = Atoms.Field
sharing Func = Atoms.Func
- sharing IntSize = Atoms.IntSize
- sharing IntX = Atoms.IntX
sharing Label = Atoms.Label
sharing Prim = Atoms.Prim
sharing ProfileLabel = Atoms.ProfileLabel
1.18 +5 -10 mlton/mlton/atoms/const.fun
Index: const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- const.fun 18 Mar 2004 03:22:22 -0000 1.17
+++ const.fun 1 May 2004 00:49:34 -0000 1.18
@@ -32,13 +32,11 @@
end
datatype t =
- Int of IntX.t
- | IntInf of IntInf.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
@@ -52,10 +50,9 @@
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
+ fn IntInf i => IntInf.layout i
| Real r => RealX.layout r
- | Word w => seq [str "0wx", WordX.layout w]
+ | Word w => WordX.layout w
| Word8Vector v => wrap ("\"", "\"", Word8.vectorToString v)
end
@@ -63,16 +60,14 @@
fun hash (c: t): word =
case c of
- Int i => String.hash (IntX.toString i)
- | IntInf i => String.hash (IntInf.toString i)
+ IntInf i => String.hash (IntInf.toString i)
| Real r => RealX.hash r
| Word w => Word.fromIntInf (WordX.toIntInf w)
| Word8Vector v => String.hash (Word8.vectorToString v)
fun equals (c, c') =
case (c, c') of
- (Int i, Int i') => IntX.equals (i, i')
- | (IntInf i, IntInf i') => IntInf.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'
1.12 +1 -4 mlton/mlton/atoms/const.sig
Index: const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- const.sig 4 Apr 2004 06:50:14 -0000 1.11
+++ const.sig 1 May 2004 00:49:34 -0000 1.12
@@ -9,7 +9,6 @@
signature CONST_STRUCTS =
sig
- structure IntX: INT_X
structure RealX: REAL_X
structure WordX: WORD_X
end
@@ -26,14 +25,12 @@
end
datatype t =
- Int of IntX.t
- | IntInf of IntInf.t
+ IntInf of IntInf.t
| Real of RealX.t
| Word of WordX.t
| Word8Vector of Word8.t vector
val equals: t * t -> bool
- val int: IntX.t -> t
val intInf: IntInf.t -> t
val hash: t -> word
val layout: t -> Layout.t
1.14 +37 -64 mlton/mlton/atoms/hash-type.fun
Index: hash-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- hash-type.fun 25 Apr 2004 06:55:44 -0000 1.13
+++ hash-type.fun 1 May 2004 00:49:34 -0000 1.14
@@ -141,8 +141,7 @@
datatype z = datatype Const.t
in
case c of
- Int i => int (IntX.size i)
- | IntInf _ => intInf
+ IntInf _ => intInf
| Real r => real (RealX.size r)
| Word w => word (WordX.size w)
| Word8Vector _ => word8Vector
@@ -218,21 +217,18 @@
local
fun make f s = let val t = f s in done ([t], t) end
in
- val intUnary = make int
val realUnary = make real
val wordUnary = make word
end
local
fun make f s = let val t = f s in done ([t, t], t) end
in
- val intBinary = make int
val realBinary = make real
val wordBinary = make word
end
local
fun make f s = let val t = f s in done ([t, t], bool) end
in
- val intCompare = make int
val realCompare = make real
val wordCompare = make word
end
@@ -246,12 +242,12 @@
fun wordShift s = done ([word s, defaultWord], word s)
in
case Prim.name prim of
- Array_array => oneTarg (fn targ => ([defaultInt], array targ))
+ Array_array => oneTarg (fn targ => ([defaultWord], array targ))
| Array_array0Const => oneTarg (fn targ => ([], array targ))
- | Array_length => oneTarg (fn t => ([array t], defaultInt))
- | Array_sub => oneTarg (fn t => ([array t, defaultInt], t))
+ | Array_length => oneTarg (fn t => ([array t], defaultWord))
+ | Array_sub => oneTarg (fn t => ([array t, defaultWord], t))
| Array_toVector => oneTarg (fn t => ([array t], vector t))
- | Array_update => oneTarg (fn t => ([array t, defaultInt, t], unit))
+ | Array_update => oneTarg (fn t => ([array t, defaultWord, t], unit))
| Exn_extra => oneTarg (fn t => ([exn], t))
| Exn_name => done ([exn], string)
| Exn_setExtendExtra =>
@@ -267,7 +263,7 @@
| IntInf_add => intInfBinary ()
| IntInf_andb => intInfBinary ()
| IntInf_arshift => intInfShift ()
- | IntInf_compare => done ([intInf, intInf], defaultInt)
+ | IntInf_compare => done ([intInf, intInf], defaultWord)
| IntInf_equal => done ([intInf, intInf], bool)
| IntInf_gcd => intInfBinary ()
| IntInf_lshift => intInfShift ()
@@ -278,47 +274,25 @@
| IntInf_quot => intInfBinary ()
| IntInf_rem => intInfBinary ()
| IntInf_sub => intInfBinary ()
- | IntInf_toString => done ([intInf, defaultInt, defaultWord], string)
+ | IntInf_toString => done ([intInf, defaultWord, defaultWord], string)
| IntInf_toVector => done ([intInf], vector defaultWord)
| IntInf_toWord => done ([intInf], defaultWord)
| IntInf_xorb => intInfBinary ()
- | Int_add s => intBinary s
- | Int_addCheck s => intBinary s
- | Int_arshift s => done ([int s, defaultWord], int s)
- | Int_equal s => intCompare s
- | Int_ge s => intCompare s
- | Int_gt s => intCompare s
- | Int_le s => intCompare s
- | Int_lshift s => done ([int s, defaultWord], int s)
- | Int_lt s => intCompare s
- | Int_mul s => intBinary s
- | Int_mulCheck s => intBinary s
- | Int_neg s => intUnary s
- | Int_negCheck s => intUnary s
- | Int_quot s => intBinary s
- | Int_rem s => intBinary s
- | Int_sub s => intBinary s
- | Int_subCheck s => intBinary s
- | Int_toInt (s, s') => done ([int s], int s')
- | Int_toReal (s, s') => done ([int s], real s')
- | Int_toWord (s, s') => done ([int s], word s')
| MLton_bogus => oneTarg (fn t => ([], t))
| MLton_bug => done ([string], unit)
| MLton_eq => oneTarg (fn t => ([t, t], bool))
| MLton_equal => oneTarg (fn t => ([t, t], bool))
- | MLton_halt => done ([defaultInt], unit)
+ | MLton_halt => done ([defaultWord], unit)
| MLton_handlesSignals => done ([], bool)
| MLton_installSignalHandler => done ([], unit)
- | MLton_size => oneTarg (fn t => ([reff t], defaultInt))
+ | MLton_size => oneTarg (fn t => ([reff t], defaultWord))
| MLton_touch => oneTarg (fn t => ([t], unit))
- | Pointer_getInt s => done ([pointer, defaultInt], int s)
- | Pointer_getPointer => oneTarg (fn t => ([pointer, defaultInt], t))
- | Pointer_getReal s => done ([pointer, defaultInt], real s)
- | Pointer_getWord s => done ([pointer, defaultInt], word s)
- | Pointer_setInt s => done ([pointer, defaultInt, int s], unit)
- | Pointer_setPointer => oneTarg (fn t => ([pointer, defaultInt, t], unit))
- | Pointer_setReal s => done ([pointer, defaultInt, real s], unit)
- | Pointer_setWord s => done ([pointer, defaultInt, word s], unit)
+ | Pointer_getPointer => oneTarg (fn t => ([pointer, defaultWord], t))
+ | Pointer_getReal s => done ([pointer, defaultWord], real s)
+ | Pointer_getWord s => done ([pointer, defaultWord], word s)
+ | Pointer_setPointer => oneTarg (fn t => ([pointer, defaultWord, t], unit))
+ | Pointer_setReal s => done ([pointer, defaultWord, real s], unit)
+ | Pointer_setWord s => done ([pointer, defaultWord, word s], unit)
| Real_Math_acos s => realUnary s
| Real_Math_asin s => realUnary s
| Real_Math_atan s => realUnary s
@@ -336,7 +310,7 @@
| Real_equal s => realCompare s
| Real_ge s => realCompare s
| Real_gt s => realCompare s
- | Real_ldexp s => done ([real s, defaultInt], real s)
+ | Real_ldexp s => done ([real s, defaultWord], real s)
| Real_le s => realCompare s
| Real_lt s => realCompare s
| Real_mul s => realBinary s
@@ -346,54 +320,53 @@
| Real_qequal s => realCompare s
| Real_round s => realUnary s
| Real_sub s => realBinary s
- | Real_toInt (s, s') => done ([real s], int s')
| Real_toReal (s, s') => done ([real s], real s')
+ | Real_toWord (s, s', _) => done ([real s], word s')
| Ref_assign => oneTarg (fn t => ([reff t, t], unit))
| Ref_deref => oneTarg (fn t => ([reff t], t))
| Ref_ref => oneTarg (fn t => ([t], reff t))
| Thread_atomicBegin => done ([], unit)
| Thread_atomicEnd => done ([], unit)
- | Thread_canHandle => done ([], defaultInt)
+ | Thread_canHandle => done ([], defaultWord)
| Thread_copy => done ([thread], thread)
| Thread_copyCurrent => done ([], unit)
| Thread_returnToC => done ([], unit)
| Thread_switchTo => done ([thread], unit)
- | Vector_length => oneTarg (fn t => ([vector t], defaultInt))
- | Vector_sub => oneTarg (fn t => ([vector t, defaultInt], t))
+ | Vector_length => oneTarg (fn t => ([vector t], defaultWord))
+ | Vector_sub => oneTarg (fn t => ([vector t, defaultWord], t))
| Weak_canGet => oneTarg (fn t => ([weak t], bool))
| Weak_get => oneTarg (fn t => ([weak t], t))
| Weak_new => oneTarg (fn t => ([t], weak t))
- | Word8Array_subWord => done ([word8Array, defaultInt], defaultWord)
+ | Word8Array_subWord => done ([word8Array, defaultWord], defaultWord)
| Word8Array_updateWord =>
- done ([word8Array, defaultInt, defaultWord], unit)
- | Word8Vector_subWord => done ([word8Vector, defaultInt], defaultWord)
+ done ([word8Array, defaultWord, defaultWord], unit)
+ | Word8Vector_subWord => done ([word8Vector, defaultWord], defaultWord)
| WordVector_toIntInf => done ([wordVector], intInf)
| Word_add s => wordBinary s
- | Word_addCheck s => wordBinary s
+ | Word_addCheck (s, _) => wordBinary s
| Word_andb s => wordBinary s
- | Word_arshift s => wordShift s
- | Word_div s => wordBinary s
| Word_equal s => wordCompare s
- | Word_ge s => wordCompare s
- | Word_gt s => wordCompare s
- | Word_le s => wordCompare s
+ | Word_ge (s, _) => wordCompare s
+ | Word_gt (s, _) => wordCompare s
+ | Word_le (s, _) => wordCompare s
| Word_lshift s => wordShift s
- | Word_lt s => wordCompare s
- | Word_mod s => wordBinary s
- | Word_mul s => wordBinary s
- | Word_mulCheck s => wordBinary s
+ | Word_lt (s, _) => wordCompare s
+ | Word_mul (s, _) => wordBinary s
+ | Word_mulCheck (s, _) => wordBinary s
| Word_neg s => wordUnary s
+ | Word_negCheck s => wordUnary s
| Word_notb s => wordUnary s
| Word_orb s => wordBinary s
+ | Word_quot (s, _) => wordBinary s
+ | Word_rem (s, _) => wordBinary s
| Word_rol s => wordShift s
| Word_ror s => wordShift s
- | Word_rshift s => wordShift s
+ | Word_rshift (s, _) => wordShift s
| Word_sub s => wordBinary s
- | Word_toInt (s, s') => done ([word s], int s')
+ | Word_subCheck (s, _) => wordBinary s
| Word_toIntInf => done ([defaultWord], intInf)
- | Word_toIntX (s, s') => done ([word s], int s')
- | Word_toWord (s, s') => done ([word s], word s')
- | Word_toWordX (s, s') => done ([word s], word s')
+ | Word_toReal (s, s', _) => done ([word s], real s')
+ | Word_toWord (s, s', _) => done ([word s], word s')
| Word_xorb s => wordBinary s
| World_save => done ([defaultWord], unit)
| _ => Error.bug (concat ["Type.checkPrimApp got strange prim: ",
1.8 +1 -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.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- hash-type.sig 12 Apr 2004 17:52:48 -0000 1.7
+++ hash-type.sig 1 May 2004 00:49:34 -0000 1.8
@@ -14,7 +14,7 @@
sig
include HASH_TYPE_STRUCTS
include TYPE_OPS
- sharing type intSize = IntSize.t
+(* sharing type intSize = IntSize.t *)
sharing type realSize = RealSize.t
sharing type tycon = Tycon.t
sharing type wordSize = WordSize.t
1.82 +251 -464 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -r1.81 -r1.82
--- prim.fun 28 Apr 2004 03:17:05 -0000 1.81
+++ prim.fun 1 May 2004 00:49:34 -0000 1.82
@@ -20,7 +20,6 @@
local
open Const
in
- structure IntX = IntX
structure WordX = WordX
end
@@ -40,7 +39,6 @@
| Array_sub (* backend *)
| Array_toVector (* backend *)
| Array_update (* backend *)
- | Char_toWord8 (* type inference *)
| Exn_extra (* implement exceptions *)
| Exn_keepHistory (* a compile-time boolean *)
| Exn_name (* implement exceptions *)
@@ -53,26 +51,6 @@
| 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_arshift of IntSize.t (* codegen *)
- | Int_equal of IntSize.t (* ssa to rssa / codegen *)
- | Int_ge of IntSize.t (* codegen *)
- | Int_gt of IntSize.t (* codegen *)
- | Int_le of IntSize.t (* codegen *)
- | Int_lshift 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_toInt of IntSize.t * 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 *)
@@ -117,11 +95,9 @@
| MLton_serialize (* unused *)
| MLton_size (* ssa to rssa *)
| MLton_touch (* backend *)
- | Pointer_getInt of IntSize.t (* ssa to rssa *)
| Pointer_getPointer (* ssa to rssa *)
| Pointer_getReal of RealSize.t (* ssa to rssa *)
| Pointer_getWord of WordSize.t (* ssa to rssa *)
- | Pointer_setInt of IntSize.t (* ssa to rssa *)
| Pointer_setPointer (* ssa to rssa *)
| Pointer_setReal of RealSize.t (* ssa to rssa *)
| Pointer_setWord of WordSize.t (* ssa to rssa *)
@@ -152,8 +128,8 @@
| Real_qequal of RealSize.t (* codegen *)
| Real_round of RealSize.t (* codegen *)
| Real_sub of RealSize.t (* codegen *)
- | Real_toInt of RealSize.t * IntSize.t (* codegen *)
| Real_toReal of RealSize.t * RealSize.t (* codegen *)
+ | Real_toWord of RealSize.t * WordSize.t * {signed: bool} (* codegen *)
| Ref_assign (* backend *)
| Ref_deref (* backend *)
| Ref_ref (* backend *)
@@ -175,34 +151,32 @@
| Weak_get (* ssa to rssa *)
| Weak_new (* ssa to rssa *)
| Word_add of WordSize.t (* codegen *)
- | Word_addCheck of WordSize.t (* codegen *)
+ | Word_addCheck of WordSize.t * {signed: bool} (* codegen *)
| Word_andb of WordSize.t (* codegen *)
- | Word_arshift of WordSize.t (* codegen *)
- | Word_div of WordSize.t (* codegen *)
| Word_equal of WordSize.t (* codegen *)
- | Word_ge of WordSize.t (* codegen *)
- | Word_gt of WordSize.t (* codegen *)
- | Word_le of WordSize.t (* codegen *)
+ | Word_ge of WordSize.t * {signed: bool} (* codegen *)
+ | Word_gt of WordSize.t * {signed: bool} (* codegen *)
+ | Word_le of WordSize.t * {signed: bool} (* 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_lt of WordSize.t * {signed: bool} (* codegen *)
+ | Word_mul of WordSize.t * {signed: bool} (* codegen *)
+ | Word_mulCheck of WordSize.t * {signed: bool} (* codegen *)
| Word_neg of WordSize.t (* codegen *)
+ | Word_negCheck of WordSize.t (* codegen *)
| Word_notb of WordSize.t (* codegen *)
| Word_orb of WordSize.t (* codegen *)
+ | Word_quot of WordSize.t * {signed: bool} (* codegen *)
+ | Word_rem of WordSize.t * {signed: bool} (* codegen *)
| Word_rol of WordSize.t (* codegen *)
| Word_ror of WordSize.t (* codegen *)
- | Word_rshift of WordSize.t (* codegen *)
+ | Word_rshift of WordSize.t * {signed: bool} (* codegen *)
| Word_sub of WordSize.t (* codegen *)
- | Word_toInt of WordSize.t * IntSize.t (* codegen *)
+ | Word_subCheck of WordSize.t* {signed: bool} (* 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_toReal of WordSize.t * RealSize.t * {signed: bool} (* codegen *)
+ | Word_toWord of WordSize.t * WordSize.t * {signed: bool} (* codegen *)
| Word_xorb of WordSize.t (* codegen *)
| WordVector_toIntInf (* ssa to rssa *)
- | Word8_toChar (* type inference *)
| Word8Array_subWord (* ssa to rssa *)
| Word8Array_updateWord (* ssa to rssa *)
| Word8Vector_subWord (* ssa to rssa *)
@@ -216,23 +190,18 @@
*)
fun toString (n: 'a t): string =
let
- fun int (s: IntSize.t, str: string): string =
- concat ["Int", IntSize.toString s, "_", str]
fun real (s: RealSize.t, str: string): string =
concat ["Real", RealSize.toString s, "_", str]
+ fun sign {signed} = if signed then "WordS" else "WordU"
fun word (s: WordSize.t, str: string): string =
concat ["Word", WordSize.toString s, "_", str]
- val intC = ("Int", IntSize.toString)
+ fun wordS (s: WordSize.t, sg, str: string): string =
+ concat [sign sg, WordSize.toString s, "_", str]
val realC = ("Real", RealSize.toString)
val wordC = ("Word", WordSize.toString)
- local
- fun make (suf, ((n, sizeToString), (n', sizeToString'),
- s, s')): string =
- concat [n, sizeToString s, "_to", n', sizeToString' s', suf]
- in
- fun coerce z = make ("", z)
- fun coerceX z = make ("X", z)
- end
+ fun wordCS sg = (sign sg, WordSize.toString)
+ fun coerce ((n, sizeToString), (n', sizeToString'), s, s'): string =
+ concat [n, sizeToString s, "_to", n', sizeToString' s']
fun pointerGet (ty, s) = concat ["Pointer_get", ty, s]
fun pointerSet (ty, s) = concat ["Pointer_set", ty, s]
in
@@ -243,7 +212,6 @@
| Array_sub => "Array_sub"
| Array_toVector => "Array_toVector"
| Array_update => "Array_update"
- | Char_toWord8 => "Char_toWord8"
| Exn_extra => "Exn_extra"
| Exn_keepHistory => "Exn_keepHistory"
| Exn_name => "Exn_name"
@@ -273,26 +241,6 @@
| IntInf_toVector => "IntInf_toVector"
| IntInf_toWord => "IntInf_toWord"
| IntInf_xorb => "IntInf_xorb"
- | Int_add s => int (s, "add")
- | Int_addCheck s => int (s, "addCheck")
- | Int_arshift s => int (s, "arshift")
- | Int_equal s => int (s, "equal")
- | Int_ge s => int (s, "ge")
- | Int_gt s => int (s, "gt")
- | Int_le s => int (s, "le")
- | Int_lshift s => int (s, "lshift")
- | Int_lt s => int (s, "lt")
- | Int_mul s => int (s, "mul")
- | Int_mulCheck s => int (s, "mulCheck")
- | Int_neg s => int (s, "neg")
- | Int_negCheck s => int (s, "negCheck")
- | Int_quot s => int (s, "quot")
- | Int_rem s => int (s, "rem")
- | Int_sub s => int (s, "sub")
- | Int_subCheck s => int (s, "subCheck")
- | Int_toInt (s1, s2) => coerce (intC, intC, s1, s2)
- | Int_toReal (s1, s2) => coerce (intC, realC, s1, s2)
- | Int_toWord (s1, s2) => coerce (intC, wordC, s1, s2)
| MLton_bogus => "MLton_bogus"
| MLton_bug => "MLton_bug"
| MLton_deserialize => "MLton_deserialize"
@@ -304,11 +252,9 @@
| MLton_serialize => "MLton_serialize"
| MLton_size => "MLton_size"
| MLton_touch => "MLton_touch"
- | Pointer_getInt s => pointerGet ("Int", IntSize.toString s)
| Pointer_getPointer => "Pointer_getPointer"
| Pointer_getReal s => pointerGet ("Real", RealSize.toString s)
| Pointer_getWord s => pointerGet ("Word", WordSize.toString s)
- | Pointer_setInt s => pointerSet ("Int", IntSize.toString s)
| Pointer_setPointer => "Pointer_setPointer"
| Pointer_setReal s => pointerSet ("Real", RealSize.toString s)
| Pointer_setWord s => pointerSet ("Word", WordSize.toString s)
@@ -339,7 +285,7 @@
| Real_qequal s => real (s, "qequal")
| Real_round s => real (s, "round")
| Real_sub s => real (s, "sub")
- | Real_toInt (s1, s2) => coerce (realC, intC, s1, s2)
+ | Real_toWord (s1, s2, sg) => coerce (realC, wordCS sg, s1, s2)
| Real_toReal (s1, s2) => coerce (realC, realC, s1, s2)
| Ref_assign => "Ref_assign"
| Ref_deref => "Ref_deref"
@@ -361,34 +307,32 @@
| Word8Array_updateWord => "Word8Array_updateWord"
| Word8Vector_subWord => "Word8Vector_subWord"
| Word8Vector_toString => "Word8Vector_toString"
- | Word8_toChar => "Word8_toChar"
| WordVector_toIntInf => "WordVector_toIntInf"
| Word_add s => word (s, "add")
- | Word_addCheck s => word (s, "addCheck")
+ | Word_addCheck (s, sg) => wordS (s, sg, "addCheck")
| Word_andb s => word (s, "andb")
- | Word_arshift s => word (s, "arshift")
- | Word_div s => word (s, "div")
| Word_equal s => word (s, "equal")
- | Word_ge s => word (s, "ge")
- | Word_gt s => word (s, "gt")
- | Word_le s => word (s, "le")
+ | Word_ge (s, sg) => wordS (s, sg, "ge")
+ | Word_gt (s, sg) => wordS (s, sg, "gt")
+ | Word_le (s, sg) => wordS (s, sg, "le")
| Word_lshift s => word (s, "lshift")
- | Word_lt s => word (s, "lt")
- | Word_mod s => word (s, "mod")
- | Word_mul s => word (s, "mul")
- | Word_mulCheck s => word (s, "mulCheck")
+ | Word_lt (s, sg) => wordS (s, sg, "lt")
+ | Word_mul (s, sg) => wordS (s, sg, "mul")
+ | Word_mulCheck (s, sg) => wordS (s, sg, "mulCheck")
| Word_neg s => word (s, "neg")
+ | Word_negCheck s => word (s, "negCheck")
| Word_notb s => word (s, "notb")
| Word_orb s => word (s, "orb")
+ | Word_quot (s, sg) => wordS (s, sg, "quot")
+ | Word_rem (s, sg) => wordS (s, sg, "rem")
| Word_rol s => word (s, "rol")
| Word_ror s => word (s, "ror")
- | Word_rshift s => word (s, "rshift")
+ | Word_rshift (s, sg) => wordS (s, sg, "rshift")
| Word_sub s => word (s, "sub")
- | Word_toInt (s1, s2) => coerce (wordC, intC, s1, s2)
+ | Word_subCheck (s, sg) => wordS (s, sg, "subCheck")
| Word_toIntInf => "Word_toIntInf"
- | Word_toIntX (s1, s2) => coerceX (wordC, intC, s1, s2)
- | Word_toWord (s1, s2) => coerce (wordC, wordC, s1, s2)
- | Word_toWordX (s1, s2) => coerceX (wordC, wordC, s1, s2)
+ | Word_toReal (s1, s2, sg) => coerce (wordCS sg, realC, s1, s2)
+ | Word_toWord (s1, s2, sg) => coerce (wordCS sg, wordC, s1, s2)
| Word_xorb s => word (s, "xorb")
| World_save => "World_save"
end
@@ -402,7 +346,6 @@
| (Array_sub, Array_sub) => true
| (Array_toVector, Array_toVector) => true
| (Array_update, Array_update) => true
- | (Char_toWord8, Char_toWord8) => true
| (Exn_extra, Exn_extra) => true
| (Exn_keepHistory, Exn_keepHistory) => true
| (Exn_name, Exn_name) => true
@@ -414,29 +357,6 @@
| (GC_collect, GC_collect) => true
| (GC_pack, GC_pack) => true
| (GC_unpack, GC_unpack) => true
- | (Int_add s, Int_add s') => IntSize.equals (s, s')
- | (Int_addCheck s, Int_addCheck s') => IntSize.equals (s, s')
- | (Int_arshift s, Int_arshift s') => IntSize.equals (s, s')
- | (Int_equal s, Int_equal s') => IntSize.equals (s, s')
- | (Int_ge s, Int_ge s') => IntSize.equals (s, s')
- | (Int_gt s, Int_gt s') => IntSize.equals (s, s')
- | (Int_le s, Int_le s') => IntSize.equals (s, s')
- | (Int_lshift s, Int_lshift s') => IntSize.equals (s, s')
- | (Int_lt s, Int_lt s') => IntSize.equals (s, s')
- | (Int_mul s, Int_mul s') => IntSize.equals (s, s')
- | (Int_mulCheck s, Int_mulCheck s') => IntSize.equals (s, s')
- | (Int_neg s, Int_neg s') => IntSize.equals (s, s')
- | (Int_negCheck s, Int_negCheck s') => IntSize.equals (s, s')
- | (Int_quot s, Int_quot s') => IntSize.equals (s, s')
- | (Int_rem s, Int_rem s') => IntSize.equals (s, s')
- | (Int_sub s, Int_sub s') => IntSize.equals (s, s')
- | (Int_subCheck s, Int_subCheck s') => IntSize.equals (s, s')
- | (Int_toInt (s1, s2), Int_toInt (s1', s2')) =>
- IntSize.equals (s1, s1') andalso IntSize.equals (s2, s2')
- | (Int_toReal (s1, s2), Int_toReal (s1', s2')) =>
- IntSize.equals (s1, s1') andalso RealSize.equals (s2, s2')
- | (Int_toWord (s1, s2), Int_toWord (s1', s2')) =>
- IntSize.equals (s1, s1') andalso WordSize.equals (s2, s2')
| (IntInf_add, IntInf_add) => true
| (IntInf_andb, IntInf_andb) => true
| (IntInf_arshift, IntInf_arshift) => true
@@ -466,11 +386,9 @@
| (MLton_serialize, MLton_serialize) => true
| (MLton_size, MLton_size) => true
| (MLton_touch, MLton_touch) => true
- | (Pointer_getInt s, Pointer_getInt s') => IntSize.equals (s, s')
| (Pointer_getPointer, Pointer_getPointer) => true
| (Pointer_getReal s, Pointer_getReal s') => RealSize.equals (s, s')
| (Pointer_getWord s, Pointer_getWord s') => WordSize.equals (s, s')
- | (Pointer_setInt s, Pointer_setInt s') => IntSize.equals (s, s')
| (Pointer_setPointer, Pointer_setPointer) => true
| (Pointer_setReal s, Pointer_setReal s') => RealSize.equals (s, s')
| (Pointer_setWord s, Pointer_setWord s') => WordSize.equals (s, s')
@@ -501,10 +419,12 @@
| (Real_qequal s, Real_qequal s') => RealSize.equals (s, s')
| (Real_round s, Real_round s') => RealSize.equals (s, s')
| (Real_sub s, Real_sub s') => RealSize.equals (s, s')
- | (Real_toInt (s1, s2), Real_toInt (s1', s2')) =>
- RealSize.equals (s1, s1') andalso IntSize.equals (s2, s2')
| (Real_toReal (s1, s2), Real_toReal (s1', s2')) =>
RealSize.equals (s1, s1') andalso RealSize.equals (s2, s2')
+ | (Real_toWord (s1, s2, sg), Real_toWord (s1', s2', sg')) =>
+ RealSize.equals (s1, s1')
+ andalso WordSize.equals (s2, s2')
+ andalso sg = sg'
| (Ref_assign, Ref_assign) => true
| (Ref_deref, Ref_deref) => true
| (Ref_ref, Ref_ref) => true
@@ -522,38 +442,49 @@
| (Weak_get, Weak_get) => true
| (Weak_new, Weak_new) => true
| (Word_add s, Word_add s') => WordSize.equals (s, s')
- | (Word_addCheck s, Word_addCheck s') => WordSize.equals (s, s')
+ | (Word_addCheck (s, sg), Word_addCheck (s', sg')) =>
+ WordSize.equals (s, s') andalso sg = sg'
| (Word_andb s, Word_andb s') => WordSize.equals (s, s')
- | (Word_arshift s, Word_arshift s') => WordSize.equals (s, s')
- | (Word_div s, Word_div s') => WordSize.equals (s, s')
| (Word_equal s, Word_equal s') => WordSize.equals (s, s')
- | (Word_ge s, Word_ge s') => WordSize.equals (s, s')
- | (Word_gt s, Word_gt s') => WordSize.equals (s, s')
- | (Word_le s, Word_le s') => WordSize.equals (s, s')
+ | (Word_ge (s, sg), Word_ge (s', sg')) =>
+ WordSize.equals (s, s') andalso sg = sg'
+ | (Word_gt (s, sg), Word_gt (s', sg')) =>
+ WordSize.equals (s, s') andalso sg = sg'
+ | (Word_le (s, sg), Word_le (s', sg')) =>
+ WordSize.equals (s, s') andalso sg = sg'
| (Word_lshift s, Word_lshift s') => WordSize.equals (s, s')
- | (Word_lt s, Word_lt s') => WordSize.equals (s, s')
- | (Word_mod s, Word_mod s') => WordSize.equals (s, s')
- | (Word_mul s, Word_mul s') => WordSize.equals (s, s')
- | (Word_mulCheck s, Word_mulCheck s') => WordSize.equals (s, s')
+ | (Word_lt (s, sg), Word_lt (s', sg')) =>
+ WordSize.equals (s, s') andalso sg = sg'
+ | (Word_mul (s, sg), Word_mul (s', sg')) =>
+ WordSize.equals (s, s') andalso sg = sg'
+ | (Word_mulCheck (s, sg), Word_mulCheck (s', sg')) =>
+ WordSize.equals (s, s') andalso sg = sg'
| (Word_neg s, Word_neg s') => WordSize.equals (s, s')
+ | (Word_negCheck s, Word_negCheck s') => WordSize.equals (s, s')
| (Word_notb s, Word_notb s') => WordSize.equals (s, s')
| (Word_orb s, Word_orb s') => WordSize.equals (s, s')
+ | (Word_quot (s, sg), Word_quot (s', sg')) =>
+ WordSize.equals (s, s') andalso sg = sg'
+ | (Word_rem (s, sg), Word_rem (s', sg')) =>
+ WordSize.equals (s, s') andalso sg = sg'
| (Word_rol s, Word_rol s') => WordSize.equals (s, s')
| (Word_ror s, Word_ror s') => WordSize.equals (s, s')
- | (Word_rshift s, Word_rshift s') => WordSize.equals (s, s')
+ | (Word_rshift (s, sg), Word_rshift (s', sg')) =>
+ WordSize.equals (s, s') andalso sg = sg'
| (Word_sub s, Word_sub s') => WordSize.equals (s, s')
- | (Word_toInt (s1, s2), Word_toInt (s1', s2')) =>
- WordSize.equals (s1, s1') andalso IntSize.equals (s2, s2')
+ | (Word_subCheck (s, sg), Word_subCheck (s', sg')) =>
+ WordSize.equals (s, s') andalso sg = sg'
| (Word_toIntInf, Word_toIntInf) => true
- | (Word_toIntX (s1, s2), Word_toIntX (s1', s2')) =>
- WordSize.equals (s1, s1') andalso IntSize.equals (s2, s2')
- | (Word_toWord (s1, s2), Word_toWord (s1', s2')) =>
- WordSize.equals (s1, s1') andalso WordSize.equals (s2, s2')
- | (Word_toWordX (s1, s2), Word_toWordX (s1', s2')) =>
- WordSize.equals (s1, s1') andalso WordSize.equals (s2, s2')
+ | (Word_toReal (s1, s2, sg), Word_toReal (s1', s2', sg')) =>
+ WordSize.equals (s1, s1')
+ andalso RealSize.equals (s2, s2')
+ andalso sg = sg'
+ | (Word_toWord (s1, s2, sg), Word_toWord (s1', s2', sg')) =>
+ WordSize.equals (s1, s1')
+ andalso WordSize.equals (s2, s2')
+ andalso sg = sg'
| (Word_xorb s, Word_xorb s') => WordSize.equals (s, s')
| (WordVector_toIntInf, WordVector_toIntInf) => true
- | (Word8_toChar, Word8_toChar) => true
| (Word8Array_subWord, Word8Array_subWord) => true
| (Word8Array_updateWord, Word8Array_updateWord) => true
| (Word8Vector_subWord, Word8Vector_subWord) => true
@@ -570,7 +501,6 @@
| Array_sub => Array_sub
| Array_toVector => Array_toVector
| Array_update => Array_update
- | Char_toWord8 => Char_toWord8
| Exn_extra => Exn_extra
| Exn_keepHistory => Exn_keepHistory
| Exn_name => Exn_name
@@ -582,26 +512,6 @@
| GC_collect => GC_collect
| GC_pack => GC_pack
| GC_unpack => GC_unpack
- | Int_add z => Int_add z
- | Int_addCheck z => Int_addCheck z
- | Int_arshift z => Int_arshift z
- | Int_equal z => Int_equal z
- | Int_ge z => Int_ge z
- | Int_gt z => Int_gt z
- | Int_le z => Int_le z
- | Int_lshift z => Int_lshift z
- | Int_lt z => Int_lt z
- | Int_mul z => Int_mul z
- | Int_mulCheck z => Int_mulCheck z
- | Int_neg z => Int_neg z
- | Int_negCheck z => Int_negCheck z
- | Int_quot z => Int_quot z
- | Int_rem z => Int_rem z
- | Int_sub z => Int_sub z
- | Int_subCheck z => Int_subCheck z
- | Int_toInt z => Int_toInt z
- | Int_toReal z => Int_toReal z
- | Int_toWord z => Int_toWord z
| IntInf_add => IntInf_add
| IntInf_andb => IntInf_andb
| IntInf_arshift => IntInf_arshift
@@ -631,11 +541,9 @@
| MLton_serialize => MLton_serialize
| MLton_size => MLton_size
| MLton_touch => MLton_touch
- | Pointer_getInt z => Pointer_getInt z
| Pointer_getPointer => Pointer_getPointer
| Pointer_getReal z => Pointer_getReal z
| Pointer_getWord z => Pointer_getWord z
- | Pointer_setInt z => Pointer_setInt z
| Pointer_setPointer => Pointer_setPointer
| Pointer_setReal z => Pointer_setReal z
| Pointer_setWord z => Pointer_setWord z
@@ -666,8 +574,8 @@
| Real_qequal z => Real_qequal z
| Real_round z => Real_round z
| Real_sub z => Real_sub z
- | Real_toInt z => Real_toInt z
| Real_toReal z => Real_toReal z
+ | Real_toWord z => Real_toWord z
| Ref_assign => Ref_assign
| Ref_deref => Ref_deref
| Ref_ref => Ref_ref
@@ -687,32 +595,30 @@
| Word_add z => Word_add z
| Word_addCheck z => Word_addCheck z
| Word_andb z => Word_andb z
- | Word_arshift z => Word_arshift z
- | Word_div z => Word_div z
| Word_equal z => Word_equal z
| Word_ge z => Word_ge z
| Word_gt z => Word_gt z
| Word_le z => Word_le z
| Word_lshift z => Word_lshift z
| Word_lt z => Word_lt z
- | Word_mod z => Word_mod z
| Word_mul z => Word_mul z
| Word_mulCheck z => Word_mulCheck z
| Word_neg z => Word_neg z
+ | Word_negCheck z => Word_negCheck z
| Word_notb z => Word_notb z
| Word_orb z => Word_orb z
| Word_rol z => Word_rol z
+ | Word_quot z => Word_quot z
+ | Word_rem z => Word_rem z
| Word_ror z => Word_ror z
| Word_rshift z => Word_rshift z
| Word_sub z => Word_sub z
- | Word_toInt z => Word_toInt z
+ | Word_subCheck z => Word_subCheck z
| Word_toIntInf => Word_toIntInf
- | Word_toIntX z => Word_toIntX z
+ | Word_toReal z => Word_toReal z
| Word_toWord z => Word_toWord z
- | Word_toWordX z => Word_toWordX z
| Word_xorb z => Word_xorb z
| WordVector_toIntInf => WordVector_toIntInf
- | Word8_toChar => Word8_toChar
| Word8Array_subWord => Word8Array_subWord
| Word8Array_updateWord => Word8Array_updateWord
| Word8Vector_subWord => Word8Vector_subWord
@@ -732,18 +638,9 @@
val ffi = FFI
val ffiSymbol = FFI_Symbol
val gcCollect = GC_collect
-val intAdd = Int_add
-val intAddCheck = Int_addCheck
-val intEqual = Int_equal
val intInfEqual = IntInf_equal
val intInfNeg = IntInf_neg
val intInfNotb = IntInf_notb
-val intMul = Int_mul
-val intMulCheck = Int_mulCheck
-val intNeg = Int_neg
-val intNegCheck = Int_negCheck
-val intSub = Int_sub
-val intSubCheck = Int_subCheck
val reff = Ref_ref
val serialize = MLton_serialize
val vectorLength = Vector_length
@@ -751,7 +648,6 @@
val wordAdd = Word_add
val wordAddCheck = Word_addCheck
val wordAndb = Word_andb
-val wordArshift = Word_arshift
val wordEqual = Word_equal
val wordGe = Word_ge
val wordGt = Word_gt
@@ -761,20 +657,16 @@
val wordMul = Word_mul
val wordMulCheck = Word_mulCheck
val wordNeg = Word_neg
+val wordNegCheck = Word_negCheck
val wordNotb = Word_notb
val wordOrb = Word_orb
val wordRshift = Word_rshift
val wordSub = Word_sub
+val wordSubCheck = Word_subCheck
val wordToWord = Word_toWord
-val wordToWordX = Word_toWordX
val isCommutative =
- fn Int_add _ => true
- | Int_addCheck _ => true
- | Int_equal _ => true
- | Int_mul _ => true
- | Int_mulCheck _ => true
- | IntInf_equal => true
+ fn IntInf_equal => true
| MLton_eq => true
| MLton_equal => true
| Real_add _ => true
@@ -791,12 +683,10 @@
| _ => false
val mayOverflow =
- fn Int_addCheck _ => true
- | Int_mulCheck _ => true
- | Int_negCheck _ => true
- | Int_subCheck _ => true
- | Word_addCheck _ => true
+ fn Word_addCheck _ => true
| Word_mulCheck _ => true
+ | Word_negCheck _ => true
+ | Word_subCheck _ => true
| _ => false
val mayRaise = mayOverflow
@@ -813,7 +703,6 @@
| Array_sub => DependsOnState
| Array_toVector => DependsOnState
| Array_update => SideEffect
- | Char_toWord8 => Functional
| Exn_extra => Functional
| Exn_keepHistory => Functional
| Exn_name => Functional
@@ -843,26 +732,6 @@
| IntInf_toVector => Functional
| IntInf_toWord => Functional
| IntInf_xorb => Functional
- | Int_add _ => Functional
- | Int_addCheck _ => SideEffect
- | Int_arshift _ => Functional
- | Int_equal _ => Functional
- | Int_ge _ => Functional
- | Int_gt _ => Functional
- | Int_le _ => Functional
- | Int_lshift _ => Functional
- | Int_lt _ => Functional
- | Int_mul _ => Functional
- | Int_mulCheck _ => SideEffect
- | Int_neg _ => Functional
- | Int_negCheck _ => SideEffect
- | Int_quot _ => Functional
- | Int_rem _ => Functional
- | Int_sub _ => Functional
- | Int_subCheck _ => SideEffect
- | Int_toInt _ => Functional
- | Int_toReal _ => Functional
- | Int_toWord _ => Functional
| MLton_bogus => Functional
| MLton_bug => SideEffect
| MLton_deserialize => Moveable
@@ -874,11 +743,9 @@
| MLton_serialize => DependsOnState
| MLton_size => DependsOnState
| MLton_touch => SideEffect
- | Pointer_getInt _ => DependsOnState
| Pointer_getPointer => DependsOnState
| Pointer_getReal _ => DependsOnState
| Pointer_getWord _ => DependsOnState
- | Pointer_setInt _ => SideEffect
| Pointer_setPointer => SideEffect
| Pointer_setReal _ => SideEffect
| Pointer_setWord _ => SideEffect
@@ -909,8 +776,8 @@
| Real_qequal _ => Functional
| Real_round _ => DependsOnState (* depends on rounding mode *)
| Real_sub _ => Functional
- | Real_toInt _ => Functional
| Real_toReal _ => Functional
+ | Real_toWord _ => Functional
| Ref_assign => SideEffect
| Ref_deref => DependsOnState
| Ref_ref => Moveable
@@ -931,34 +798,32 @@
| Word8Array_updateWord => SideEffect
| Word8Vector_subWord => Functional
| Word8Vector_toString => Functional
- | Word8_toChar => Functional
| WordVector_toIntInf => Functional
| Word_add _ => Functional
| Word_addCheck _ => SideEffect
| Word_andb _ => Functional
- | Word_arshift _ => Functional
- | Word_div _ => Functional
| Word_equal _ => Functional
| Word_ge _ => Functional
| Word_gt _ => Functional
| Word_le _ => Functional
| Word_lshift _ => Functional
| Word_lt _ => Functional
- | Word_mod _ => Functional
| Word_mul _ => Functional
| Word_mulCheck _ => SideEffect
| Word_neg _ => Functional
+ | Word_negCheck _ => SideEffect
| Word_notb _ => Functional
| Word_orb _ => Functional
+ | Word_quot _ => Functional
+ | Word_rem _ => Functional
| Word_rol _ => Functional
| Word_ror _ => Functional
| Word_rshift _ => Functional
| Word_sub _ => Functional
- | Word_toInt _ => Functional
+ | Word_subCheck _ => SideEffect
| Word_toIntInf => Functional
- | Word_toIntX _ => Functional
+ | Word_toReal _ => Functional
| Word_toWord _ => Functional
- | Word_toWordX _ => Functional
| Word_xorb _ => Functional
| World_save => SideEffect
end
@@ -968,25 +833,6 @@
fun maySideEffect p = Kind.SideEffect = kind p
local
- fun ints (s: IntSize.t) =
- [(Int_add s),
- (Int_addCheck s),
- (Int_arshift s),
- (Int_equal s),
- (Int_ge s),
- (Int_gt s),
- (Int_le s),
- (Int_lshift s),
- (Int_lt s),
- (Int_mul s),
- (Int_mulCheck s),
- (Int_neg s),
- (Int_negCheck s),
- (Int_quot s),
- (Int_rem s),
- (Int_sub s),
- (Int_subCheck s)]
-
fun reals (s: RealSize.t) =
[(Real_Math_acos s),
(Real_Math_asin s),
@@ -1016,29 +862,39 @@
(Real_round s),
(Real_sub s)]
+ fun wordSigns (s: WordSize.t, signed: bool) =
+ let
+ val sg = {signed = signed}
+ in
+ List.map ([Word_addCheck,
+ Word_ge,
+ Word_gt,
+ Word_le,
+ Word_lt,
+ Word_mul,
+ Word_mulCheck,
+ Word_quot,
+ Word_rem,
+ Word_rshift,
+ Word_subCheck],
+ fn p => p (s, sg))
+ end
+
fun words (s: WordSize.t) =
[(Word_add s),
- (Word_addCheck s),
(Word_andb s),
- (Word_arshift s),
- (Word_div s),
(Word_equal s),
- (Word_ge s),
- (Word_gt s),
- (Word_le s),
(Word_lshift s),
- (Word_lt s),
- (Word_mod s),
- (Word_mul s),
- (Word_mulCheck s),
(Word_neg s),
+ (Word_negCheck s),
(Word_notb s),
(Word_orb s),
(Word_rol s),
(Word_ror s),
- (Word_rshift s),
(Word_sub s),
(Word_xorb s)]
+ @ wordSigns (s, true)
+ @ wordSigns (s, false)
in
val all: unit t list =
[Array_array,
@@ -1047,7 +903,6 @@
Array_sub,
Array_toVector,
Array_update,
- Char_toWord8,
Exn_extra,
Exn_name,
Exn_setExtendExtra,
@@ -1106,40 +961,38 @@
Weak_new,
Word_toIntInf,
WordVector_toIntInf,
- Word8_toChar,
Word8Array_subWord,
Word8Array_updateWord,
Word8Vector_subWord,
Word8Vector_toString,
World_save]
- @ List.concat [List.concatMap (IntSize.prims, ints),
- List.concatMap (RealSize.all, reals),
+ @ List.concat [List.concatMap (RealSize.all, reals),
List.concatMap (WordSize.prims, words)]
@ let
- val int = IntSize.all
val real = RealSize.all
val word = WordSize.all
- fun coerces (name, sizes, sizes') =
+ fun coerces (name, sizes, sizes', ac) =
List.fold
- (sizes, [], fn (s, ac) =>
- List.fold (sizes', ac, fn (s', ac) => name (s, s') :: ac))
+ ([false, true], ac, fn (signed, ac) =>
+ List.fold
+ (sizes, ac, fn (s, ac) =>
+ List.fold (sizes', ac, fn (s', ac) =>
+ name (s, s', {signed = signed}) :: ac)))
in
- List.concat [coerces (Int_toInt, int, int),
- coerces (Int_toReal, int, real),
- coerces (Int_toWord, int, word),
- coerces (Real_toInt, real, int),
- coerces (Real_toReal, real, real),
- coerces (Word_toInt, word, int),
- coerces (Word_toIntX, word, int),
- coerces (Word_toWord, word, word),
- coerces (Word_toWordX, word, word)]
+ coerces (Real_toWord, real, word,
+ coerces (Word_toReal, word, real,
+ coerces (Word_toWord, word, word,
+ List.fold
+ (real, [], fn (s, ac) =>
+ List.fold
+ (real, ac, fn (s', ac) =>
+ Real_toReal (s, s') :: ac)))))
end
@ let
fun doit (all, get, set) =
List.concatMap (all, fn s => [get s, set s])
in
- List.concat [doit (IntSize.prims, Pointer_getInt, Pointer_setInt),
- doit (RealSize.all, Pointer_getReal, Pointer_setReal),
+ List.concat [doit (RealSize.all, Pointer_getReal, Pointer_setReal),
doit (WordSize.prims, Pointer_getWord, Pointer_setWord)]
end
end
@@ -1303,7 +1156,6 @@
datatype z = datatype t
datatype z = datatype Const.t
val bool = ApplyResult.Bool
- val int = ApplyResult.Const o Const.int
val intInf = ApplyResult.Const o Const.intInf
val intInfConst = intInf o IntInf.fromInt
fun word (w: WordX.t): ('a, 'b) ApplyResult.t =
@@ -1312,59 +1164,48 @@
val t = ApplyResult.truee
val f = ApplyResult.falsee
fun iio (f, c1, c2) = intInf (f (c1, c2))
- fun io (f: IntX.t * IntX.t -> IntX.t, i, i') =
- int (f (i, i'))
+ fun wordS (f: WordX.t * WordX.t * {signed: bool} -> WordX.t,
+ (_: WordSize.t, sg),
+ w: WordX.t,
+ w': WordX.t) =
+ word (f (w, w', sg))
+ fun wordCmp (f: WordX.t * WordX.t * {signed: bool} -> bool,
+ (_: WordSize.t, sg),
+ w: WordX.t,
+ w': WordX.t) =
+ bool (f (w, w', sg))
+ fun wordOrOverflow (s, sg, w) =
+ if WordSize.isInRange (s, w, sg)
+ then word (WordX.fromIntInf (w, s))
+ else ApplyResult.Overflow
fun wcheck (f: IntInf.t * IntInf.t -> IntInf.t,
+ (s: WordSize.t, sg as {signed}),
w: WordX.t,
- w': WordX.t,
- s: WordSize.t) =
+ w': WordX.t) =
let
- val x = f (WordX.toIntInf w, WordX.toIntInf w')
+ val conv = if signed then WordX.toIntInfX else WordX.toIntInf
in
- if x <= WordX.toIntInf (WordX.max s)
- then word (WordX.fromIntInf (x, s))
- else ApplyResult.Overflow
+ wordOrOverflow (s, sg, f (conv w, conv w'))
end
val eq =
- fn (Int i1, Int i2) => bool (IntX.equals (i1, i2))
- | (Word w1, Word w2) => bool (WordX.equals (w1, w2))
+ fn (Word w1, Word w2) => bool (WordX.equals (w1, w2))
| _ => ApplyResult.Unknown
val equal =
- fn (Int i1, Int i2) => bool (IntX.equals (i1, i2))
- | (Word w1, Word w2) => bool (WordX.equals (w1, w2))
+ fn (Word w1, Word w2) => bool (WordX.equals (w1, w2))
| (Word8Vector v1, Word8Vector v2) => bool (v1 = v2)
| _ => ApplyResult.Unknown
fun allConsts (cs: Const.t list) =
(case (p, cs) of
- (Int_add _, [Int i1, Int i2]) => io (IntX.+, i1, i2)
- | (Int_addCheck _, [Int i1, Int i2]) => io (IntX.+, i1, i2)
- | (Int_arshift _, [Int i, Word w]) =>
- int (IntX.~>> (i, WordX.toIntInf w))
- | (Int_equal _, [Int i1, Int i2]) => bool (IntX.equals (i1, i2))
- | (Int_ge _, [Int i1, Int i2]) => bool (IntX.>= (i1, i2))
- | (Int_gt _, [Int i1, Int i2]) => bool (IntX.> (i1, i2))
- | (Int_le _, [Int i1, Int i2]) => bool (IntX.<= (i1, i2))
- | (Int_lshift _, [Int i, Word w]) =>
- int (IntX.<< (i, WordX.toIntInf w))
- | (Int_lt _, [Int i1, Int i2]) => bool (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_toInt (_, s), [Int i]) =>
- int (IntX.make (IntX.toIntInf i, s))
- | (Int_toWord (_, s), [Int i]) =>
- word (WordX.fromIntInf (IntX.toIntInf i, s))
- | (IntInf_compare, [IntInf i1, IntInf i2]) =>
- int (IntX.make (IntInf.fromInt (case IntInf.compare (i1, i2) of
- Relation.LESS => ~1
- | Relation.EQUAL => 0
- | Relation.GREATER => 1),
- IntSize.default))
+ (IntInf_compare, [IntInf i1, IntInf i2]) =>
+ let
+ val i =
+ case IntInf.compare (i1, i2) of
+ Relation.LESS => ~1
+ | Relation.EQUAL => 0
+ | Relation.GREATER => 1
+ in
+ word (WordX.fromIntInf (i, WordSize.default))
+ end
| (IntInf_equal, [IntInf i1, IntInf i2]) => bool (i1 = i2)
| (IntInf_toWord, [IntInf i]) =>
(case SmallIntInf.toWord i of
@@ -1373,37 +1214,42 @@
WordSize.default)))
| (MLton_eq, [c1, c2]) => eq (c1, c2)
| (MLton_equal, [c1, c2]) => equal (c1, c2)
- | (Word_add _, [Word w1, Word w2]) => word (WordX.+ (w1, w2))
- | (Word_addCheck s, [Word w1, Word w2]) =>
- wcheck (IntInf.+, w1, w2, s)
+ | (Word_add _, [Word w1, Word w2]) => word (WordX.add (w1, w2))
+ | (Word_addCheck s, [Word w1, Word w2]) => wcheck (op +, s, w1, w2)
| (Word_andb _, [Word w1, Word w2]) => word (WordX.andb (w1, w2))
- | (Word_arshift _, [Word w1, Word w2]) => word (WordX.~>> (w1, w2))
- | (Word_div _, [Word w1, Word w2]) => word (WordX.div (w1, w2))
| (Word_equal _, [Word w1, Word w2]) => bool (WordX.equals (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_ge s, [Word w1, Word w2]) => wordCmp (WordX.ge, s, w1, w2)
+ | (Word_gt s, [Word w1, Word w2]) => wordCmp (WordX.gt, s, w1, w2)
+ | (Word_le s, [Word w1, Word w2]) => wordCmp (WordX.le, s, 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_lt s, [Word w1, Word w2]) => wordCmp (WordX.lt, s, w1, w2)
+ | (Word_mul s, [Word w1, Word w2]) => wordS (WordX.mul, s, w1, w2)
+ | (Word_mulCheck s, [Word w1, Word w2]) => wcheck (op *, s, w1, w2)
+ | (Word_neg s, [Word w]) => word (WordX.neg w)
+ | (Word_negCheck s, [Word w]) =>
+ wordOrOverflow (s, {signed = true}, ~ (WordX.toIntInfX w))
| (Word_notb _, [Word w]) => word (WordX.notb w)
| (Word_orb _, [Word w1, Word w2]) => word (WordX.orb (w1, w2))
+ | (Word_quot s, [Word w1, Word w2]) =>
+ if WordX.isZero w2
+ then ApplyResult.Unknown
+ else wordS (WordX.quot, s, w1, w2)
+ | (Word_rem s, [Word w1, Word w2]) =>
+ if WordX.isZero w2
+ then ApplyResult.Unknown
+ else wordS (WordX.rem, s, 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_rshift s, [Word w1, Word w2]) =>
+ wordS (WordX.rshift, s, w1, w2)
+ | (Word_sub _, [Word w1, Word w2]) => word (WordX.sub (w1, w2))
+ | (Word_subCheck s, [Word w1, Word w2]) => wcheck (op -, s, w1, w2)
| (Word_toIntInf, [Word w]) =>
intInf (SmallIntInf.fromWord
(Word.fromIntInf (WordX.toIntInf w)))
- | (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_toWord (_, s, {signed}), [Word w]) =>
+ word (if signed then WordX.resizeX (w, s)
+ else WordX.resize (w, s))
| (Word_xorb _, [Word w1, Word w2]) => word (WordX.xorb (w1, w2))
| _ => ApplyResult.Unknown)
handle Chr => ApplyResult.Unknown
@@ -1413,14 +1259,6 @@
fun someVars () =
let
datatype z = datatype ApplyResult.t
- fun add (x: 'b, i: IntX.t): ('a, 'b) ApplyResult.t =
- if IntX.isZero i then Var x else Unknown
- fun mul (x: 'b, 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
fun varIntInf (x, i: IntInf.t, space, inOrder) =
let
fun neg () = Apply (intInfNeg, [x, space])
@@ -1473,12 +1311,20 @@
let
val zero = word o WordX.zero
fun add () = if WordX.isZero w then Var x else Unknown
- fun mul () =
+ fun mul ((s, {signed}), neg) =
if WordX.isZero w
then word w
else if WordX.isOne w
then Var x
- else Unknown
+ else if signed andalso WordX.isNegOne w
+ then Apply (neg s, [x])
+ else Unknown
+ fun sub (s, neg) =
+ if WordX.isZero w
+ then if inOrder
+ then Var x
+ else Apply (neg s, [x])
+ else Unknown
fun ro () =
if inOrder
then
@@ -1486,12 +1332,13 @@
val s = WordX.size w
in
if WordX.isZero
- (WordX.mod
+ (WordX.rem
(w,
WordX.fromIntInf
(IntInf.fromInt
(Bits.toInt (WordSize.bits s)),
- s)))
+ s),
+ {signed = false}))
then Var x
else Unknown
end
@@ -1503,11 +1350,12 @@
if inOrder
then if WordX.isZero w
then Var x
- else if (WordX.>=
+ else if (WordX.ge
(w,
WordX.fromIntInf (Bits.toIntInf
(WordSize.bits s),
- WordSize.default)))
+ WordSize.default),
+ {signed = false}))
then zero s
else Unknown
else if WordX.isZero w
@@ -1523,53 +1371,60 @@
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 _ =>
+ | Word_ge (_, sg) =>
if inOrder
- then if WordX.isZero w then t else Unknown
- else if WordX.isMax w then t else Unknown
- | Word_gt _ =>
+ then if WordX.isMin (w, sg) then t else Unknown
+ else if WordX.isMax (w, sg) then t else Unknown
+ | Word_gt (_, sg) =>
if inOrder
- then if WordX.isMax w then f else Unknown
- else if WordX.isZero w then f else Unknown
- | Word_le _ =>
+ then if WordX.isMax (w, sg) then f else Unknown
+ else if WordX.isMin (w, sg) then f else Unknown
+ | Word_le (_, sg) =>
if inOrder
- then if WordX.isMax w then t else Unknown
- else if WordX.isZero w then t else Unknown
+ then if WordX.isMax (w, sg) then t else Unknown
+ else if WordX.isMin (w, sg) then t else Unknown
| Word_lshift s => shift s
- | Word_lt _ =>
+ | Word_lt (_, sg) =>
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 ()
+ then if WordX.isMin (w, sg) then f else Unknown
+ else if WordX.isMax (w, sg) then f else Unknown
+ | Word_mul s => mul (s, wordNeg)
+ | Word_mulCheck s => mul (s, wordNegCheck)
| 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
+ | Word_quot (s, {signed}) =>
+ if inOrder
then
- if inOrder
+ if WordX.isOne w
then Var x
- else Apply (wordNeg s, [x])
+ else if signed andalso WordX.isNegOne w
+ then Apply (wordNeg s, [x])
+ else Unknown
else Unknown
+ | Word_rem (s, {signed}) =>
+ if inOrder
+ andalso (WordX.isOne w
+ orelse signed andalso WordX.isNegOne w)
+ then zero s
+ else Unknown
+ | Word_rol _ => ro ()
+ | Word_ror _ => ro ()
+ | Word_rshift (s, {signed}) =>
+ if signed
+ then
+ if WordX.isZero w
+ then if inOrder then Var x else zero s
+ else if WordX.isAllOnes w andalso not inOrder
+ then word w
+ else Unknown
+ else
+ shift s
+ | Word_sub s => sub (s, wordNeg)
+ | Word_subCheck s => sub (s, wordNegCheck o #1)
| Word_xorb s =>
if WordX.isZero w
then Var x
@@ -1581,10 +1436,10 @@
datatype z = datatype ApplyArg.t
in
case (p, args) of
- (IntInf_toString, [Const (IntInf i), Const (Int base), _]) =>
+ (IntInf_toString, [Const (IntInf i), Const (Word base), _]) =>
let
val base =
- case IntX.toInt base of
+ case WordX.toInt base of
2 => StringCvt.BIN
| 8 => StringCvt.OCT
| 10 => StringCvt.DEC
@@ -1606,54 +1461,6 @@
else Unknown
| (_, [Var x, Const (Word i)]) => varWord (x, i, true)
| (_, [Const (Word i), Var x]) => varWord (x, i, false)
- | (_, [Var x, Const (Int i)]) =>
- (case p of
- Int_add _ => add (x, i)
- | Int_addCheck _ => 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 p of
- 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 p of
IntInf_add => iio (IntInf.+, i1, i2)
@@ -1718,16 +1525,8 @@
datatype z = datatype ApplyResult.t
in
case p of
- Int_equal _ => t
- | 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_compare =>
+ word (WordX.zero WordSize.default)
| IntInf_equal => t
| MLton_eq => t
| MLton_equal => t
@@ -1738,14 +1537,14 @@
| Real_ge _ => t
| Real_qequal _ => t
| Word_andb _ => Var x
- | Word_div s => word (WordX.one s)
| Word_equal _ => t
| Word_ge _ => t
| Word_gt _ => f
| Word_le _ => t
| Word_lt _ => f
- | Word_mod s => word (WordX.zero s)
| Word_orb _ => Var x
+ | Word_quot (s, _) => word (WordX.one s)
+ | Word_rem (s, _) => word (WordX.zero s)
| Word_sub s => word (WordX.zero s)
| Word_xorb s => word (WordX.zero s)
| _ => Unknown
@@ -1772,20 +1571,7 @@
fun two name = seq [arg 0, str " ", str name, str " ", arg 1]
in
case p of
- Int_mul _ => two "*?"
- | Int_mulCheck _ => two "*"
- | Int_add _ => two "+?"
- | Int_addCheck _ => two "+"
- | Int_sub _ => two "-?"
- | Int_subCheck _ => two "-"
- | Int_equal _ => two "="
- | Int_lt _ => two "<"
- | Int_le _ => two "<="
- | Int_gt _ => two ">"
- | Int_ge _ => two ">="
- | Int_neg _ => one "-?"
- | Int_negCheck _ => one "-"
- | IntInf_equal => two "="
+ IntInf_equal => two "="
| MLton_eq => two "="
| Real_Math_acos _ => one "acos"
| Real_Math_asin _ => one "asin"
@@ -1813,23 +1599,24 @@
| Ref_ref => one "ref"
| Vector_length => one "length"
| Word_add _ => two "+"
- | Word_addCheck _ => two "+c"
+ | Word_addCheck _ => two "+"
| Word_andb _ => two "&"
- | Word_arshift _ => two "~>>"
| Word_equal _ => two "="
| Word_ge _ => two ">="
| Word_gt _ => two ">"
| Word_le _ => two "<="
| Word_lshift _ => two "<<"
| Word_lt _ => two "<"
- | Word_mul _ => two "*"
- | Word_mulCheck _ => two "*c"
+ | Word_mul (_, {signed}) => two "*"
+ | Word_mulCheck _ => two "*"
| Word_neg _ => one "-"
+ | Word_negCheck _ => one "-"
| Word_orb _ => two "|"
| Word_rol _ => two "rol"
| Word_ror _ => two "ror"
- | Word_rshift _ => two ">>"
+ | Word_rshift (_, {signed}) => two (if signed then "~>>" else ">>")
| Word_sub _ => two "-"
+ | Word_subCheck (_, {signed}) => two "-"
| Word_xorb _ => two "^"
| _ => seq [layout p, str " ", Vector.layout layoutArg args]
end
1.62 +25 -60 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.61
retrieving revision 1.62
diff -u -r1.61 -r1.62
--- prim.sig 25 Apr 2004 22:02:49 -0000 1.61
+++ prim.sig 1 May 2004 00:49:34 -0000 1.62
@@ -11,10 +11,8 @@
structure CType: C_TYPE
structure Con: CON
structure Const: CONST
- structure IntSize: INT_SIZE
structure RealSize: REAL_SIZE
structure WordSize: WORD_SIZE
- sharing IntSize = Const.IntX.IntSize
sharing RealSize = Const.RealX.RealSize
sharing WordSize = Const.WordX.WordSize
end
@@ -32,7 +30,6 @@
| Array_sub (* backend *)
| Array_toVector (* backend *)
| Array_update (* backend *)
- | Char_toWord8 (* type inference *)
| Exn_extra (* implement exceptions *)
| Exn_keepHistory (* a compile-time boolean *)
| Exn_name (* implement exceptions *)
@@ -45,26 +42,6 @@
| 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_arshift of IntSize.t (* codegen *)
- | Int_equal of IntSize.t (* ssa to rssa / 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_lshift 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_toInt of IntSize.t * 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 *)
@@ -109,11 +86,9 @@
| MLton_serialize (* unused *)
| MLton_size (* ssa to rssa *)
| MLton_touch (* backend *)
- | Pointer_getInt of IntSize.t (* ssa to rssa *)
| Pointer_getPointer (* ssa to rssa *)
| Pointer_getReal of RealSize.t (* ssa to rssa *)
| Pointer_getWord of WordSize.t (* ssa to rssa *)
- | Pointer_setInt of IntSize.t (* ssa to rssa *)
| Pointer_setPointer (* ssa to rssa *)
| Pointer_setReal of RealSize.t (* ssa to rssa *)
| Pointer_setWord of WordSize.t (* ssa to rssa *)
@@ -144,7 +119,7 @@
| Real_qequal of RealSize.t (* codegen *)
| Real_round of RealSize.t (* codegen *)
| Real_sub of RealSize.t (* codegen *)
- | Real_toInt of RealSize.t * IntSize.t (* codegen *)
+ | Real_toWord of RealSize.t * WordSize.t * {signed: bool} (* codegen *)
| Real_toReal of RealSize.t * RealSize.t (* codegen *)
| Ref_assign (* backend *)
| Ref_deref (* backend *)
@@ -167,34 +142,32 @@
| Weak_get (* ssa to rssa *)
| Weak_new (* ssa to rssa *)
| Word_add of WordSize.t (* codegen *)
- | Word_addCheck of WordSize.t (* codegen *)
+ | Word_addCheck of WordSize.t * {signed: bool} (* codegen *)
| Word_andb of WordSize.t (* codegen *)
- | Word_arshift of WordSize.t (* codegen *)
- | Word_div of WordSize.t (* codegen *)
| Word_equal of WordSize.t (* codegen *)
- | Word_ge of WordSize.t (* codegen *)
- | Word_gt of WordSize.t (* codegen *)
- | Word_le of WordSize.t (* codegen *)
+ | Word_ge of WordSize.t * {signed: bool} (* codegen *)
+ | Word_gt of WordSize.t * {signed: bool} (* codegen *)
+ | Word_le of WordSize.t * {signed: bool} (* 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_lt of WordSize.t * {signed: bool} (* codegen *)
+ | Word_mul of WordSize.t * {signed: bool} (* codegen *)
+ | Word_mulCheck of WordSize.t * {signed: bool} (* codegen *)
| Word_neg of WordSize.t (* codegen *)
+ | Word_negCheck of WordSize.t (* codegen *)
| Word_notb of WordSize.t (* codegen *)
| Word_orb of WordSize.t (* codegen *)
+ | Word_quot of WordSize.t * {signed: bool} (* codegen *)
+ | Word_rem of WordSize.t * {signed: bool} (* codegen *)
| Word_rol of WordSize.t (* codegen *)
| Word_ror of WordSize.t (* codegen *)
- | Word_rshift of WordSize.t (* codegen *)
+ | Word_rshift of WordSize.t * {signed: bool} (* codegen *)
| Word_sub of WordSize.t (* codegen *)
- | Word_toInt of WordSize.t * IntSize.t (* codegen *)
+ | Word_subCheck of WordSize.t* {signed: bool} (* 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_toReal of WordSize.t * RealSize.t * {signed: bool} (* codegen *)
+ | Word_toWord of WordSize.t * WordSize.t * {signed: bool} (* codegen *)
| Word_xorb of WordSize.t (* codegen *)
| WordVector_toIntInf (* ssa to rssa *)
- | Word8_toChar (* type inference *)
| Word8Array_subWord (* ssa to rssa *)
| Word8Array_updateWord (* ssa to rssa *)
| Word8Vector_subWord (* ssa to rssa *)
@@ -254,13 +227,6 @@
val fromString: string -> 'a t
val gcCollect: 'a t
val intInfEqual: 'a t
- val intAdd: IntSize.t -> 'a t
- val intAddCheck: IntSize.t -> 'a t
- val intEqual: IntSize.t -> 'a t
- val intMul: IntSize.t -> 'a t
- val intMulCheck: IntSize.t -> 'a t
- val intSub: IntSize.t -> 'a t
- val intSubCheck: IntSize.t -> 'a t
val isCommutative: 'a t -> bool
(*
* isFunctional p = true iff p always returns same result when given
@@ -287,21 +253,20 @@
val vectorLength: 'a t
val vectorSub: 'a t
val wordAdd: WordSize.t -> 'a t
- val wordAddCheck: WordSize.t -> 'a t
+ val wordAddCheck: WordSize.t * {signed: bool} -> 'a t
val wordAndb: WordSize.t -> 'a t
- val wordArshift: WordSize.t -> 'a t
val wordEqual: WordSize.t -> 'a t
- val wordGe: WordSize.t -> 'a t
- val wordGt: WordSize.t -> 'a t
- val wordLe: WordSize.t -> 'a t
- val wordLt: WordSize.t -> 'a t
+ val wordGe: WordSize.t * {signed: bool} -> 'a t
+ val wordGt: WordSize.t * {signed: bool} -> 'a t
+ val wordLe: WordSize.t * {signed: bool} -> 'a t
+ val wordLt: WordSize.t * {signed: bool} -> 'a t
val wordLshift: WordSize.t -> 'a t
- val wordMul: WordSize.t -> 'a t
- val wordMulCheck: WordSize.t -> 'a t
+ val wordMul: WordSize.t * {signed: bool} -> 'a t
+ val wordMulCheck: WordSize.t * {signed: bool} -> 'a t
val wordNeg: WordSize.t -> 'a t
val wordOrb: WordSize.t -> 'a t
- val wordRshift: WordSize.t -> 'a t
+ val wordRshift: WordSize.t * {signed: bool} -> 'a t
val wordSub: WordSize.t -> 'a t
- val wordToWord: WordSize.t * WordSize.t -> 'a t
- val wordToWordX: WordSize.t * WordSize.t -> 'a t
+ val wordSubCheck: WordSize.t * {signed: bool} -> 'a t
+ val wordToWord: WordSize.t * WordSize.t * {signed: bool} -> 'a t
end
1.23 +0 -3 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- sources.cm 25 Apr 2004 06:55:44 -0000 1.22
+++ sources.cm 1 May 2004 00:49:34 -0000 1.23
@@ -10,7 +10,6 @@
signature AST
signature ATOMS
signature ID
-signature INT_X
signature C_FUNCTION
signature C_TYPE
signature CON
@@ -50,8 +49,6 @@
(* Windows doesn't like files named con, so use con- instead. *)
con-.sig
con-.fun
-int-x.sig
-int-x.fun
real-x.sig
real-x.fun
word-x.sig
1.13 +0 -2 mlton/mlton/atoms/type-ops.fun
Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- type-ops.fun 12 Apr 2004 17:52:56 -0000 1.12
+++ type-ops.fun 1 May 2004 00:49:34 -0000 1.13
@@ -27,7 +27,6 @@
in
val bool = nullary Tycon.bool
val exn = nullary Tycon.exn
- val int = IntSize.memoize (fn s => nullary (Tycon.int s))
val intInf = nullary Tycon.intInf
val preThread = nullary Tycon.preThread
val real = RealSize.memoize (fn s => nullary (Tycon.real s))
@@ -35,7 +34,6 @@
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
1.10 +0 -3 mlton/mlton/atoms/type-ops.sig
Index: type-ops.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- type-ops.sig 12 Apr 2004 17:52:56 -0000 1.9
+++ type-ops.sig 1 May 2004 00:49:34 -0000 1.10
@@ -25,7 +25,6 @@
* the Tycon structure, which will cause duplicate specifications later
* on.
*)
- type intSize
type realSize
type tycon
type wordSize
@@ -51,11 +50,9 @@
val deVector: t -> t
val deWeak: t -> t
val deWeakOpt: t -> t option
- val defaultInt: t
val defaultReal: t
val defaultWord: t
val exn: t
- val int: intSize -> t
val intInf: t
val isTuple: t -> bool
val list: t -> t
1.9 +72 -30 mlton/mlton/atoms/word-x.fun
Index: word-x.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/word-x.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- word-x.fun 4 Apr 2004 06:50:14 -0000 1.8
+++ word-x.fun 1 May 2004 00:49:34 -0000 1.9
@@ -1,3 +1,10 @@
+(* Copyright (C) 2004 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under the GNU General Public License (GPL).
+ * Please see the file MLton-LICENSE for license information.
+ *)
+
functor WordX (S: WORD_X_STRUCTS): WORD_X =
struct
@@ -27,9 +34,23 @@
val value = make #value
end
-fun toString w = IntInf.format (value w, StringCvt.HEX)
+val toIntInf = value
+
+fun toIntInfX w =
+ let
+ val v = value w
+ val m = modulus (size w)
+ in
+ if v >= m div 2
+ then v - m
+ else v
+ end
+
+val toInt = IntInf.toInt o toIntInf
-val layout = Layout.str o toString
+fun toString w = IntInf.format (toIntInf w, StringCvt.HEX)
+
+fun layout w = Layout.str (concat ["0x", toString w])
fun zero s = make (0, s)
@@ -59,36 +80,39 @@
fun isAllOnes w = value w = modulus (size w) - 1
-val isMax = isAllOnes
-
fun isOne w = 1 = value w
fun isZero w = 0 = value w
-fun max s = make (modulus s - 1, s)
+fun isNegOne w = ~1 = toIntInfX w
+
+local
+ fun make f (s, sg) = fromIntInf (f (s, sg), s)
+in
+ val max = make WordSize.max
+ val min = make WordSize.min
+end
+
+local
+ fun make f (w, sg) = equals (w, f (size w, sg))
+in
+ val isMax = make max
+ val isMin = make min
+end
fun notb w = make (IntInf.notb (value w), size w)
fun one s = make (1, s)
-fun resize (w, s) = make (value w, s)
-
-fun toIntInfX w =
- let
- val v = value w
- val m = modulus (size w)
- in
- if v >= m div 2
- then v - m
- else v
- end
+fun toIntInfSg (w, {signed}) =
+ if signed then toIntInfX w else toIntInf w
+fun resize (w, s) = make (toIntInf w, s)
+
fun resizeX (w, s) = make (toIntInfX w, s)
fun toChar (w: t): char = Char.fromInt (Int.fromIntInf (value w))
-val toIntInf = value
-
fun ~>> (w, w') =
let
val shift = value w'
@@ -101,6 +125,9 @@
make (IntInf.~>> (toIntInfX w, shift), s)
end
+fun rshift (w, w', {signed}) =
+ if signed then ~>> (w, w') else >> (w, w')
+
fun swap (i: IntInf.t, {hi: word, lo: word}) =
let
open IntInf
@@ -150,27 +177,42 @@
then make (f (value w, value w'), size w)
else raise Fail "WordX binary"
in
- val op + = make IntInf.+
- val op - = make IntInf.-
- val op * = make IntInf.*
+ val add = make IntInf.+
+ val sub = make IntInf.-
val andb = make IntInf.andb
- val op div = make IntInf.div
- val op mod = make IntInf.mod
val orb = make IntInf.orb
val xorb = make IntInf.xorb
end
+fun neg w = make (~ (toIntInfX w), size w)
+
local
- val make: (IntInf.t * IntInf.t -> 'a) -> t * t -> 'a =
- fn f => fn (w, w') =>
+ val make: (IntInf.t * IntInf.t -> IntInf.t) -> t * t * {signed: bool}-> t =
+ fn f => fn (w, w', s) =>
if WordSize.equals (size w, size w')
- then f (value w, value w')
+ then make (f (toIntInfSg (w, s), toIntInfSg (w', s)), size w)
+ else raise Fail "WordX binary"
+in
+ val mul = make IntInf.*
+ val quot = make IntInf.quot
+ val rem = make IntInf.rem
+end
+
+local
+ val make: (IntInf.t * IntInf.t -> 'a) -> t * t * {signed: bool} -> 'a =
+ fn f => fn (w, w', sg) =>
+ if WordSize.equals (size w, size w')
+ then f (toIntInfSg (w, sg), toIntInfSg (w', sg))
else Error.bug "WordX compare"
in
- val op < = make IntInf.<
- val op <= = make IntInf.<=
- val op > = make IntInf.>
- val op >= = make IntInf.>=
+ val lt = make IntInf.<
+ val le = make IntInf.<=
+ val gt = make IntInf.>
+ val ge = make IntInf.>=
end
+
+fun layoutSg {signed} = Layout.record [("signed", Bool.layout signed)]
+
+val lt = Trace.trace3 ("WordX.lt", layout, layout, layoutSg, Bool.layout) lt
end
1.6 +26 -13 mlton/mlton/atoms/word-x.sig
Index: word-x.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/word-x.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- word-x.sig 4 Apr 2004 06:50:14 -0000 1.5
+++ word-x.sig 1 May 2004 00:49:34 -0000 1.6
@@ -1,3 +1,12 @@
+(* Copyright (C) 2004 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under the GNU General Public License (GPL).
+ * Please see the file MLton-LICENSE for license information.
+ *)
+
+type int = Int.t
+
signature WORD_X_STRUCTS =
sig
structure WordSize: WORD_SIZE
@@ -11,40 +20,44 @@
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 add: t * t -> t
val andb: t * t -> t
val bitIsSet: t * Int.t -> bool
- val div: t * t -> t
val equals: t * t -> bool
+ val ge: t * t * {signed: bool} -> bool
+ val gt: t * t * {signed: bool} -> bool
val fromChar: char -> t (* returns a word of size 8 *)
val fromIntInf: IntInf.t * WordSize.t -> t
val fromWord8: Word8.t -> t
val isAllOnes: t -> bool
val isOne: t -> bool
- val isMax: t -> bool
+ val isMax: t * {signed: bool} -> bool
+ val isMin: t * {signed: bool} -> bool
+ val isNegOne: t -> bool
val isZero: t -> bool
val layout: t -> Layout.t
- val max: WordSize.t -> t
- val mod: t * t -> t
+ val le: t * t * {signed: bool} -> bool
+ val lt: t * t * {signed: bool} -> bool
+ val max: WordSize.t * {signed: bool} -> t
+ val min: WordSize.t * {signed: bool} -> t
+ val mul: t * t * {signed: bool} -> t
+ val neg: t -> t
val notb: t -> t
val one: WordSize.t -> t
val orb: t * t -> t
+ val quot: t * t * {signed: bool} -> t
+ val rem: t * t * {signed: bool} -> t
val resize: t * WordSize.t -> t
val resizeX: t * WordSize.t -> t
val rol: t * t -> t
val ror: t * t -> t
+ val rshift : t * t * {signed: bool} -> t
val size: t -> WordSize.t
val splice: {hi: t, lo: t} -> t
val split: t * {lo: Bits.t} -> {hi: t, lo: t}
+ val sub: t * t -> t
val toChar: t -> char
+ val toInt: t -> int
val toIntInf: t -> IntInf.t
val toIntInfX: t -> IntInf.t
val toString: t -> string
1.70 +9 -9 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -r1.69 -r1.70
--- backend.fun 27 Apr 2004 08:10:49 -0000 1.69
+++ backend.fun 1 May 2004 00:49:35 -0000 1.70
@@ -15,7 +15,6 @@
open Machine
in
structure Global = Global
- structure IntX = IntX
structure Label = Label
structure PointerTycon = PointerTycon
structure RealX = RealX
@@ -133,7 +132,7 @@
start = start}
end
-fun toMachine (program: Ssa.Program.t) =
+fun toMachine (program: Ssa.Program.t, codegen) =
let
fun pass (name, doit, program) =
Control.passTypeCheck {display = Control.Layouts Rssa.Program.layouts,
@@ -142,7 +141,7 @@
suffix = "rssa",
thunk = fn () => doit program,
typeCheck = R.Program.typeCheck}
- val program = pass ("ssaToRssa", SsaToRssa.convert, program)
+ val program = pass ("ssaToRssa", SsaToRssa.convert, (program, codegen))
val program = pass ("insertLimitChecks", LimitCheck.insert, program)
val program = pass ("insertSignalChecks", SignalCheck.insert, program)
val program = pass ("implementHandlers", ImplementHandlers.doit, program)
@@ -372,8 +371,7 @@
datatype z = datatype Const.t
in
case c of
- Int i => M.Operand.Int i
- | IntInf i =>
+ IntInf i =>
(case Const.SmallIntInf.toWord i of
NONE => globalIntInf i
| SOME w =>
@@ -498,10 +496,12 @@
(M.Statement.PrimApp
{args = (Vector.new2
(stackTopOp,
- M.Operand.Int
- (IntX.defaultInt
- (Bytes.toInt
- (Bytes.+ (handlerOffset (), Bytes.inWord)))))),
+ M.Operand.Word
+ (WordX.fromIntInf
+ (Int.toIntInf
+ (Bytes.toInt
+ (Bytes.+ (handlerOffset (), Bytes.inWord))),
+ WordSize.default)))),
dst = SOME tmp,
prim = Prim.wordAdd WordSize.default},
M.Statement.PrimApp
1.12 +4 -1 mlton/mlton/backend/backend.sig
Index: backend.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- backend.sig 4 Apr 2004 06:50:16 -0000 1.11
+++ backend.sig 1 May 2004 00:49:35 -0000 1.12
@@ -21,5 +21,8 @@
sig
include BACKEND_STRUCTS
- val toMachine: Ssa.Program.t -> Machine.Program.t
+ val toMachine:
+ Ssa.Program.t
+ * {codegenImplementsPrim: Machine.Type.t Machine.Prim.t -> bool}
+ -> Machine.Program.t
end
1.51 +6 -4 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- limit-check.fun 27 Apr 2004 08:10:49 -0000 1.50
+++ limit-check.fun 1 May 2004 00:49:35 -0000 1.51
@@ -123,6 +123,7 @@
ensureFree: Label.t -> Bytes.t) =
let
val {args, blocks, name, raises, returns, start} = Function.dest f
+ val greaterThan = Prim.wordGt (WordSize.default, {signed = false})
val newBlocks = ref []
local
val r: Label.t option ref = ref NONE
@@ -291,7 +292,7 @@
fun stackCheck (maybeFirst, z): Label.t =
let
val (statements, transfer) =
- primApp (Prim.wordGt WordSize.default,
+ primApp (greaterThan,
Operand.Runtime StackTop,
Operand.Runtime StackLimit,
z)
@@ -340,7 +341,7 @@
dst = SOME (res, Type.defaultWord),
prim = Prim.wordSub WordSize.default}
val (statements, transfer) =
- primApp (Prim.wordGt WordSize.default,
+ primApp (greaterThan,
amount,
Operand.Var {var = res, ty = Type.defaultWord},
z)
@@ -369,7 +370,7 @@
fun heapCheckNonZero (bytes: Bytes.t): Label.t =
if Bytes.<= (bytes, Runtime.limitSlop)
then frontierCheck (true,
- Prim.wordGt WordSize.default,
+ greaterThan,
Operand.Runtime Frontier,
Operand.Runtime Limit,
insert (Operand.word
@@ -419,7 +420,8 @@
bytesNeeded),
dst = bytes,
overflow = allocTooLarge (),
- prim = Prim.wordAddCheck WordSize.default,
+ prim = Prim.wordAddCheck (WordSize.default,
+ {signed = false}),
success = (heapCheck
(false,
Operand.Var {var = bytes,
1.65 +2 -11 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- machine.fun 25 Apr 2004 06:55:44 -0000 1.64
+++ machine.fun 1 May 2004 00:49:35 -0000 1.65
@@ -16,7 +16,6 @@
structure RepType = RepType (structure CFunction = CFunction
structure CType = CType
structure IntSize = IntSize
- structure IntX = IntX
structure Label = Label
structure PointerTycon = PointerTycon
structure Prim = Prim
@@ -175,7 +174,6 @@
| Frontier
| GCState
| Global of Global.t
- | Int of IntX.t
| Label of Label.t
| Line
| Offset of {base: t,
@@ -205,9 +203,8 @@
| Frontier => Type.defaultWord
| GCState => Type.gcState
| Global g => Global.ty g
- | Int i => Type.int (IntX.size i)
| Label l => Type.label l
- | Line => Type.defaultInt
+ | Line => Type.defaultWord
| Offset {ty, ...} => ty
| Real r => Type.real (RealX.size r)
| Register r => Register.ty r
@@ -237,7 +234,6 @@
| Frontier => str "<Frontier>"
| GCState => str "<GCState>"
| Global g => Global.layout g
- | Int i => IntX.layout i
| Label l => Label.layout l
| Line => str "<Line>"
| Offset {base, offset, ty} =>
@@ -248,7 +244,7 @@
| Register r => Register.layout r
| StackOffset so => StackOffset.layout so
| StackTop => str "<StackTop>"
- | Word w => seq [str "0x", WordX.layout w]
+ | Word w => WordX.layout w
end
val toString = Layout.toString o layout
@@ -264,7 +260,6 @@
| (File, File) => true
| (GCState, GCState) => true
| (Global g, Global g') => Global.equals (g, g')
- | (Int i, Int i') => IntX.equals (i, i')
| (Label l, Label l') => Label.equals (l, l')
| (Line, Line) => true
| (Offset {base = b, offset = i, ...},
@@ -938,9 +933,6 @@
(checkOperand (z, alloc)
; (Type.castIsOk
{from = Operand.ty z,
- fromInt = (case z of
- Int i => SOME i
- | _ => NONE),
to = t,
tyconTy = tyconTy}))
| Contents {oper, ...} =>
@@ -956,7 +948,6 @@
*)
true
orelse Alloc.doesDefine (alloc, x)
- | Int _ => true
| Label l =>
(let val _ = labelBlock l
in true
1.46 +0 -1 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- machine.sig 25 Apr 2004 06:55:44 -0000 1.45
+++ machine.sig 1 May 2004 00:49:35 -0000 1.46
@@ -73,7 +73,6 @@
| Frontier
| GCState
| Global of Global.t
- | Int of IntX.t
| Label of Label.t
| Line (* expand by codegen into int constant *)
| Offset of {base: t,
1.12 +18 -14 mlton/mlton/backend/packed-representation.fun
Index: packed-representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/packed-representation.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- packed-representation.fun 28 Apr 2004 03:17:05 -0000 1.11
+++ packed-representation.fun 1 May 2004 00:49:35 -0000 1.12
@@ -167,7 +167,8 @@
val andb = make (valOf o Type.andb, Prim.wordAndb)
val lshift = make (Type.lshift, Prim.wordLshift)
val orb = make (valOf o Type.orb, Prim.wordOrb)
- val rshift = make (Type.rshift, Prim.wordRshift)
+ val rshift = make (Type.rshift, fn s =>
+ Prim.wordRshift (s, {signed = false}))
end
end
@@ -395,7 +396,10 @@
let
val (s, src) =
Statement.andb
- (src, Operand.word (WordX.resize (WordX.max s, s')))
+ (src,
+ Operand.word (WordX.resize
+ (WordX.max (s, {signed = false}), s')))
+
in
(src, [s])
end
@@ -994,10 +998,10 @@
seq [str "ShiftAndTag ",
record [("component", Component.layout component),
("selects", Selects.layout selects),
- ("tag", seq [str "0x", WordX.layout tag]),
+ ("tag", WordX.layout tag),
("ty", Type.layout ty)]]
| Tag {tag} =>
- seq [str "Tag 0x", WordX.layout tag]
+ seq [str "Tag ", WordX.layout tag]
| Transparent => str "Transparent"
| Unit => str "Unit"
end
@@ -1165,7 +1169,8 @@
else default
val cases =
QuickSort.sortVector
- (cases, fn ((w, _), (w', _)) => WordX.<= (w, w'))
+ (cases, fn ((w, _), (w', _)) =>
+ WordX.le (w, w', {signed = false}))
val headerTy = headerTy ()
val (s, tag) =
Statement.rshift (Offset {base = test,
@@ -1231,10 +1236,11 @@
Block.new {statements = statements,
transfer = transfer})
end
- | ConRep.Tag {tag} => SOME (WordX.resize (tag, wordSize), l)
+ | ConRep.Tag {tag} =>
+ SOME (WordX.resize (tag, wordSize), l)
| _ => NONE)
val cases = QuickSort.sortVector (cases, fn ((w, _), (w', _)) =>
- WordX.<= (w, w'))
+ WordX.le (w, w', {signed = false}))
val (tagOp, ss) =
if isEnum
then (test, [])
@@ -1244,7 +1250,8 @@
Statement.andb
(test,
Operand.word (WordX.resize
- (WordX.max (WordSize.fromBits tagBits),
+ (WordX.max (WordSize.fromBits tagBits,
+ {signed = false}),
wordSize)))
in
(tag, [s])
@@ -1416,7 +1423,9 @@
con: Con.t,
pointerTycon: PointerTycon.t} vector)
: t * {con: Con.t, rep: ConRep.t} vector =
- if 1 = Vector.length variants
+ if 0 = Vector.length variants
+ then (Unit, Vector.new0 ())
+ else if 1 = Vector.length variants
then
let
val {args, con, pointerTycon} = Vector.sub (variants, 0)
@@ -2094,7 +2103,6 @@
in
r'
end
- | Int s => nonPointer (Type.int s)
| IntInf =>
constant (Rep.T {rep = Rep.Pointer {endsIn00 = false},
ty = Type.intInf})
@@ -2252,10 +2260,6 @@
if Tycon.equals (c, Tycon.bool)
then SOME Type.bool
else normal ()
- | Int s =>
- if true
- then normal ()
- else SOME (Type.int (IntSize.roundUpToPrim s))
| _ => normal ()
end
fun makeSrc (v, oper) {index} = oper (Vector.sub (v, index))
1.6 +32 -54 mlton/mlton/backend/rep-type.fun
Index: rep-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rep-type.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- rep-type.fun 28 Apr 2004 03:17:05 -0000 1.5
+++ rep-type.fun 1 May 2004 00:49:35 -0000 1.6
@@ -38,7 +38,7 @@
in
case dest t of
Address t => seq [str "Address ", layout t]
- | Constant w => seq [str "0x", WordX.layout w, str ":",
+ | Constant w => seq [WordX.layout w, str ":",
WordSize.layout (WordX.size w)]
| ExnStack => str "ExnStack"
| GCState => str "GCState"
@@ -123,8 +123,6 @@
val real = T o Real
val word = T o Word
- val int = word o IntSize.bits
-
val char = word Bits.inByte
fun zero b = constant (WordX.zero (WordSize.fromBits b))
@@ -201,7 +199,6 @@
Word b => Bits.equals (b, Bits.inPointer)
| _ => false
- val defaultInt = int IntSize.default
val defaultWord = word Bits.inWord
val word8 = word Bits.inByte
@@ -217,7 +214,7 @@
seq (Vector.new2
(constant (WordX.fromIntInf
(1, WordSize.fromBits (Bits.fromInt 1))),
- int (IntSize.I (Bits.fromInt 31))))))
+ word (Bits.fromInt 31)))))
local
fun make is t =
@@ -495,7 +492,7 @@
fun mulConstant (t: t, w: WordX.t): t =
case dest t of
- Constant w' => constant (WordX.* (w, w'))
+ Constant w' => constant (WordX.mul (w, w', {signed = false}))
| _ =>
let
val n = width t
@@ -865,7 +862,7 @@
WordSize.default))
fun arrayOffsetIsOk {base: t, index: t, pointerTy, result: t}: bool =
- isSubtype (index, defaultInt)
+ isSubtype (index, defaultWord)
andalso
case dest base of
Pointer p =>
@@ -893,7 +890,7 @@
(case pointerTy p of
ObjectType.Array _ =>
if Bytes.equals (offset, Runtime.arrayLengthOffset)
- then SOME defaultInt
+ then SOME defaultWord
else NONE
| ObjectType.Normal t => SOME (frag t)
| _ => NONE)
@@ -947,7 +944,7 @@
| StackTop => cPointer ()
end
-fun castIsOk {from, fromInt = _, to, tyconTy = _} =
+fun castIsOk {from, to, tyconTy = _} =
Bits.equals (width from, width to)
fun checkPrimApp {args: t vector, prim: t Prim.t, result: t option}: bool =
@@ -985,30 +982,25 @@
local
open Type
in
- val defaultInt = defaultInt
val defaultWord = defaultWord
- val int = int
val real = real
val word = word o WordSize.bits
end
local
fun make f s = let val t = f s in unary (t, t) end
in
- val intUnary = make int
val realUnary = make real
val wordUnary = make word
end
local
fun make f s = let val t = f s in binary (t, t, t) end
in
- val intBinary = make int
val realBinary = make real
val wordBinary = make word
end
local
fun make f s = let val t = f s in binary (t, t, bool) end
in
- val intCompare = make int
val realCompare = make real
val wordCompare = make word
end
@@ -1030,24 +1022,6 @@
Vector.equals (args, expects, isSubtype) andalso done return
end
| FFI_Symbol {ty, ...} => nullary ty
- | Int_add s => intBinary s
- | Int_addCheck s => intBinary s
- | Int_equal s => intCompare s
- | Int_ge s => intCompare s
- | Int_gt s => intCompare s
- | Int_le s => intCompare s
- | Int_lt s => intCompare s
- | Int_mul s => intBinary s
- | Int_mulCheck s => intBinary s
- | Int_neg s => intUnary s
- | Int_negCheck s => intUnary s
- | Int_quot s => intBinary s
- | Int_rem s => intBinary s
- | Int_sub s => intBinary s
- | Int_subCheck s => intBinary s
- | Int_toInt (s, s') => unary (int s, int s')
- | Int_toReal (s, s') => unary (int s, real s')
- | Int_toWord (s, s') => unary (int s, word s')
| MLton_eq =>
two (fn (t1, t2) =>
(isSubtype (t1, t2) orelse isSubtype (t2, t1))
@@ -1069,7 +1043,7 @@
| Real_equal s => realCompare s
| Real_ge s => realCompare s
| Real_gt s => realCompare s
- | Real_ldexp s => binary (real s, defaultInt, real s)
+ | Real_ldexp s => binary (real s, defaultWord, real s)
| Real_le s => realCompare s
| Real_lt s => realCompare s
| Real_mul s => realBinary s
@@ -1079,37 +1053,42 @@
| Real_qequal s => realCompare s
| Real_round s => realUnary s
| Real_sub s => realBinary s
- | Real_toInt (s, s') => unary (real s, int s')
| Real_toReal (s, s') => unary (real s, real s')
+ | Real_toWord (s, s', _) => unary (real s, word s')
| Thread_returnToC => nullary unit
| Word_add _ => twoWord add
- | Word_addCheck s => wordBinary s
+ | Word_addCheck (s, _) => wordBinary s
| Word_andb _ => twoOpt andb
- | Word_arshift _ => wordShift' arshift
- | Word_div s => wordBinary s
| Word_equal s => wordCompare s
- | Word_ge s => wordCompare s
- | Word_gt s => wordCompare s
- | Word_le s => wordCompare s
+ | Word_ge (s, _) => wordCompare s
+ | Word_gt (s, _) => wordCompare s
+ | Word_le (s, _) => wordCompare s
| Word_lshift _ => wordShift' lshift
- | Word_lt s => wordCompare s
- | Word_mod s => wordBinary s
- | Word_mul _ => twoWord mul
- | Word_mulCheck s => wordBinary s
+ | Word_lt (s, _) => wordCompare s
+ | Word_mul (s, {signed}) =>
+ if signed
+ then wordBinary s
+ else twoWord mul
+ | Word_mulCheck (s, _) => wordBinary s
| Word_neg s => wordUnary s
+ | Word_negCheck s => wordUnary s
| Word_notb s => wordUnary s
| Word_orb _ => twoOpt orb
+ | Word_quot (s, _) => wordBinary s
+ | Word_rem (s, _) => wordBinary s
| Word_rol s => wordShift s
| Word_ror s => wordShift s
- | Word_rshift _ => wordShift' rshift
+ | Word_rshift (_, {signed}) =>
+ wordShift' (if signed then arshift else rshift)
| Word_sub s => wordBinary s
- | Word_toInt (s, s') => unary (word s, int s')
- | Word_toIntX (s, s') => unary (word s, int s')
- | Word_toWord (s, s') =>
- one (fn t =>
- isSubtype (t, word s)
- andalso done (resize (t, (WordSize.bits s'))))
- | Word_toWordX (s, s') => unary (word s, word s')
+ | Word_subCheck (s, _) => wordBinary s
+ | Word_toReal (s, s', _) => unary (word s, real s')
+ | Word_toWord (s, s', {signed}) =>
+ if signed
+ then unary (word s, word s')
+ else one (fn t =>
+ isSubtype (t, word s)
+ andalso done (resize (t, (WordSize.bits s'))))
| Word_xorb s => wordBinary s
| _ => Error.bug (concat ["strange primitive to Prim.typeCheck: ",
Prim.toString prim])
@@ -1137,7 +1116,6 @@
local
open Type
in
- val Int32 = int (IntSize.I (Bits.fromInt 32))
val Word32 = word (Bits.fromInt 32)
val unit = unit
end
@@ -1147,7 +1125,7 @@
T {args = let
open Type
in
- Vector.new5 (gcState, Word32, bool, cPointer (), Int32)
+ Vector.new5 (gcState, Word32, bool, cPointer (), Word32)
end,
bytesNeeded = NONE,
convention = Cdecl,
1.5 +0 -6 mlton/mlton/backend/rep-type.sig
Index: rep-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rep-type.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- rep-type.sig 27 Apr 2004 08:10:49 -0000 1.4
+++ rep-type.sig 1 May 2004 00:49:35 -0000 1.5
@@ -9,8 +9,6 @@
sig
structure CFunction: C_FUNCTION
structure CType: C_TYPE
- structure IntSize: INT_SIZE
- structure IntX: INT_X
structure Label: LABEL
structure PointerTycon: POINTER_TYCON
structure Prim: PRIM
@@ -19,7 +17,6 @@
structure WordSize: WORD_SIZE
structure WordX: WORD_X
sharing CFunction = Prim.CFunction
- sharing IntSize = IntX.IntSize = Prim.IntSize
sharing RealSize = Prim.RealSize
sharing WordSize = Prim.WordSize = WordX.WordSize
end
@@ -66,7 +63,6 @@
val bool: t
val bytes: t -> Bytes.t
val castIsOk: {from: t,
- fromInt: IntX.t option,
to: t,
tyconTy: PointerTycon.t -> ObjectType.t} -> bool
val checkPrimApp: {args: t vector,
@@ -75,7 +71,6 @@
val char: t
val cPointer: unit -> t
val constant: WordX.t -> t
- val defaultInt: t
val defaultWord: t
val dest: t -> dest
val dropPrefix: t * Bits.t -> t
@@ -85,7 +80,6 @@
val fragment: t * {start: Bits.t, width: Bits.t} -> t
val fromCType: CType.t -> t
val gcState: t
- val int: IntSize.t -> t
val intInf: t
val isBool: t -> bool
val isCPointer: t -> bool
1.32 +6 -5 mlton/mlton/backend/representation.fun
Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- representation.fun 28 Apr 2004 03:17:05 -0000 1.31
+++ representation.fun 1 May 2004 00:49:35 -0000 1.32
@@ -427,7 +427,7 @@
if isTagged
then {mutable = false,
offset = Bytes.zero,
- ty = Type.int IntSize.default} :: components
+ ty = Type.defaultWord} :: components
else components
val components =
QuickSort.sortArray
@@ -678,7 +678,6 @@
case S.Type.dest t of
Array t => SOME (array {mutable = true, ty = t})
| Datatype tycon => convertDatatype tycon
- | Int s => SOME (Type.int (IntSize.roundUpToPrim s))
| IntInf => SOME Type.intInf
| Real s => SOME (Type.real s)
| Ref t =>
@@ -842,7 +841,7 @@
val cases =
QuickSort.sortVector
(cases, fn ((w, _), (w', _)) =>
- WordX.<= (w, w'))
+ WordX.le (w, w', {signed = false}))
in
Switch (Switch.T {cases = cases,
default = default,
@@ -971,7 +970,8 @@
else default
val cases =
QuickSort.sortVector
- (cases, fn ((w, _), (w', _)) => WordX.<= (w, w'))
+ (cases, fn ((w, _), (w', _)) =>
+ WordX.le (w, w', {signed = false}))
val headerOffset = Bytes.fromInt ~4
val tagVar = Var.newNoname ()
val tagTy =
@@ -992,7 +992,8 @@
Type.pointerHeader))},
Operand.word (WordX.one WordSize.default))),
dst = SOME (tagVar, tagTy),
- prim = Prim.wordRshift WordSize.default}
+ prim = Prim.wordRshift (WordSize.default,
+ {signed = false})}
in
([s],
Transfer.Switch
1.12 +0 -1 mlton/mlton/backend/representation.sig
Index: representation.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- representation.sig 19 Apr 2004 02:38:02 -0000 1.11
+++ representation.sig 1 May 2004 00:49:35 -0000 1.12
@@ -11,7 +11,6 @@
sig
structure Rssa: RSSA
structure Ssa: SSA
- sharing Rssa.IntSize = Ssa.IntSize
sharing Rssa.RealSize = Ssa.RealSize
sharing Rssa.WordSize = Ssa.WordSize
end
1.58 +13 -17 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- rssa.fun 28 Apr 2004 03:17:05 -0000 1.57
+++ rssa.fun 1 May 2004 00:49:35 -0000 1.58
@@ -66,8 +66,9 @@
| Var of {var: Var.t,
ty: Type.t}
- val int = Const o Const.int
val word = Const o Const.word
+
+ fun zero s = word (WordX.fromIntInf (0, s))
fun bool b =
word (WordX.fromIntInf (if b then 1 else 0, WordSize.default))
@@ -80,8 +81,7 @@
datatype z = datatype Const.t
in
case c of
- Int i => Type.int (IntX.size i)
- | IntInf _ => Type.intInf
+ IntInf _ => Type.intInf
| Real r => Type.real (RealX.size r)
| Word w => Type.constant w
| Word8Vector _ => Type.word8Vector
@@ -89,7 +89,7 @@
| EnsuresBytesFree => Type.defaultWord
| File => Type.cPointer ()
| GCState => Type.gcState
- | Line => Type.int IntSize.default
+ | Line => Type.defaultWord
| Offset {ty, ...} => ty
| PointerTycon _ => Type.defaultWord
| Runtime z => Type.ofGCField z
@@ -121,7 +121,7 @@
end
fun cast (z, t) =
- if Type.isSubtype (t, ty z)
+ if Type.isSubtype (ty z, t)
then z
else Cast (z, t)
@@ -294,7 +294,8 @@
[PrimApp {args = Vector.new1 z,
dst = SOME (tmp, tmpTy),
prim = Prim.wordToWord (WordSize.fromBits w,
- WordSize.fromBits b)}])
+ WordSize.fromBits b,
+ {signed = false})}])
end
end
end
@@ -1045,16 +1046,9 @@
result = ty})
| Cast (z, ty) =>
(checkOperand z
- ; (Type.castIsOk
- {from = Operand.ty z,
- fromInt = (case z of
- Const c =>
- (case c of
- Const.Int n => SOME n
- | _ => NONE)
- | _ => NONE),
- to = ty,
- tyconTy = tyconTy}))
+ ; Type.castIsOk {from = Operand.ty z,
+ to = ty,
+ tyconTy = tyconTy})
| Const _ => true
| EnsuresBytesFree => true
| File => true
@@ -1083,7 +1077,9 @@
datatype z = datatype Statement.t
in
case s of
- Bind {src, ...} => (checkOperand src; true)
+ Bind {src, dst = (_, dstTy), ...} =>
+ (checkOperand src
+ ; Type.isSubtype (Operand.ty src, dstTy))
| Move {dst, src} =>
(checkOperand dst
; checkOperand src
1.38 +1 -1 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- rssa.sig 28 Apr 2004 03:17:05 -0000 1.37
+++ rssa.sig 1 May 2004 00:49:35 -0000 1.38
@@ -66,11 +66,11 @@
val caseBytes: t * {big: t -> 'a,
small: Bytes.t -> 'a} -> 'a
val cast: t * Type.t -> 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: WordX.t -> t
+ val zero: WordSize.t -> t
end
sharing Operand = Switch.Use
1.77 +133 -426 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.76
retrieving revision 1.77
diff -u -r1.76 -r1.77
--- ssa-to-rssa.fun 27 Apr 2004 08:10:50 -0000 1.76
+++ ssa-to-rssa.fun 1 May 2004 00:49:35 -0000 1.77
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -39,7 +39,6 @@
open Type
in
val gcState = gcState
- val Int32 = int (IntSize.I (Bits.fromInt 32))
val Word32 = word (Bits.fromInt 32)
val unit = unit
end
@@ -71,7 +70,7 @@
return = Type.thread}
val exit =
- T {args = Vector.new1 Int32,
+ T {args = Vector.new1 Word32,
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = false,
@@ -83,7 +82,7 @@
return = unit}
fun gcArrayAllocate {return} =
- T {args = Vector.new4 (gcState, Word32, Int32, Word32),
+ T {args = Vector.new4 (gcState, Word32, Word32, Word32),
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = true,
@@ -172,7 +171,7 @@
fun size t =
vanilla {args = Vector.new1 t,
name = "MLton_size",
- return = Int32}
+ return = Word32}
end
structure Name =
@@ -184,36 +183,17 @@
fun cFunctionRaise (n: t): CFunction.t =
let
datatype z = datatype CFunction.Convention.t
+ val name = toString n
val word = Type.word o WordSize.bits
val vanilla = CFunction.vanilla
- val intC = ("Int", Type.int, IntSize.toString)
+ val intC = ("Int", Type.word, IntSize.toString)
val realC = ("Real", Type.real, RealSize.toString)
val wordC = ("Word", word, WordSize.toString)
- fun coerce (s1, (fromName, fromType, fromString),
- s2, (toName, toType, toString)) =
- vanilla {args = Vector.new1 (fromType s1),
- name = concat [fromName, fromString s1,
- "_to", toName, toString s2],
- return = toType s2}
- fun coerceX (s1, (fromName, fromType, fromString),
- s2, (toName, toType, toString)) =
- vanilla {args = Vector.new1 (fromType s1),
- name = concat [fromName, fromString s1,
- "_to", toName, toString s2, "X"],
- return = toType s2}
- fun intBinary (s, name) =
- let
- val t = Type.int s
- in
- vanilla {args = Vector.new2 (t, t),
- name = concat ["Int", IntSize.toString s, "_", name],
- return = t}
- end
- fun intCompare (s, name) =
- vanilla {args = Vector.new2 (Type.int s, Type.int s),
- name = concat ["Int", IntSize.toString s, "_", name],
- return = Type.bool}
- fun intInfBinary name =
+ fun coerce (t1, t2) =
+ vanilla {args = Vector.new1 t1,
+ name = name,
+ return = t2}
+ fun intInfBinary () =
CFunction.T {args = Vector.new3 (Type.intInf, Type.intInf,
Type.defaultWord),
bytesNeeded = SOME 2,
@@ -223,9 +203,9 @@
maySwitchThreads = false,
modifiesFrontier = true,
modifiesStackTop = false,
- name = concat ["IntInf_", name],
+ name = name,
return = Type.intInf}
- fun intInfShift name =
+ fun intInfShift () =
CFunction.T {args = Vector.new3 (Type.intInf,
Type.defaultWord,
Type.defaultWord),
@@ -236,11 +216,11 @@
maySwitchThreads = false,
modifiesFrontier = true,
modifiesStackTop = false,
- name = concat ["IntInf_", name],
+ name = name,
return = Type.intInf}
- val intInfToString =
+ fun intInfToString () =
CFunction.T {args = Vector.new3 (Type.intInf,
- Type.defaultInt,
+ Type.defaultWord,
Type.defaultWord),
bytesNeeded = SOME 2,
convention = Cdecl,
@@ -249,9 +229,9 @@
maySwitchThreads = false,
modifiesFrontier = true,
modifiesStackTop = false,
- name = "IntInf_toString",
+ name = name,
return = Type.string}
- fun intInfUnary name =
+ fun intInfUnary () =
CFunction.T {args = Vector.new2 (Type.intInf, Type.defaultWord),
bytesNeeded = SOME 1,
convention = Cdecl,
@@ -260,284 +240,82 @@
maySwitchThreads = false,
modifiesFrontier = true,
modifiesStackTop = false,
- name = concat ["IntInf_", name],
+ name = name,
return = Type.intInf}
- fun wordBinary (s, name) =
+ fun wordBinary s =
let
val t = word s
in
vanilla {args = Vector.new2 (t, t),
- name = concat ["Word", WordSize.toString s,
- "_", name],
+ name = name,
return = t}
end
- fun wordCompare (s, name) =
+ fun wordCompare s =
vanilla {args = Vector.new2 (word s, word s),
- name = concat ["Word", WordSize.toString s, "_", name],
+ name = name,
return = Type.bool}
- fun wordShift (s, name) =
+ fun wordShift s =
vanilla {args = Vector.new2 (word s, Type.defaultWord),
- name = concat ["Word", WordSize.toString s, "_", name],
+ name = name,
return = word s}
- fun wordUnary (s, name) =
+ fun wordUnary s =
vanilla {args = Vector.new1 (word s),
- name = concat ["Word", WordSize.toString s, "_", name],
+ name = name,
return = word s}
in
case n of
- Int_ge s => intCompare (s, "ge")
- | Int_gt s => intCompare (s, "gt")
- | Int_le s => intCompare (s, "le")
- | Int_lt s => intCompare (s, "lt")
- | Int_mul s => intBinary (s, "mul")
- | Int_quot s => intBinary (s, "quot")
- | Int_rem s => intBinary (s, "rem")
- | Int_toReal (s1, s2) => coerce (s1, intC, s2, realC)
- | IntInf_add => intInfBinary "add"
- | IntInf_andb => intInfBinary "andb"
- | IntInf_arshift => intInfShift "arshift"
+ IntInf_add => intInfBinary ()
+ | IntInf_andb => intInfBinary ()
+ | IntInf_arshift => intInfShift ()
| IntInf_compare =>
vanilla {args = Vector.new2 (Type.intInf, Type.intInf),
- name = "IntInf_compare",
- return = Type.defaultInt}
+ name = name,
+ return = Type.defaultWord}
| IntInf_equal =>
vanilla {args = Vector.new2 (Type.intInf, Type.intInf),
- name = "IntInf_equal",
+ name = name,
return = Type.bool}
- | IntInf_gcd => intInfBinary "gcd"
- | IntInf_lshift => intInfShift "lshift"
- | IntInf_mul => intInfBinary "mul"
- | IntInf_neg => intInfUnary "neg"
- | IntInf_notb => intInfUnary "notb"
- | IntInf_orb => intInfBinary "orb"
- | IntInf_quot => intInfBinary "quot"
- | IntInf_rem => intInfBinary "rem"
- | IntInf_sub => intInfBinary "sub"
- | IntInf_toString => intInfToString
- | IntInf_xorb => intInfBinary "xorb"
+ | IntInf_gcd => intInfBinary ()
+ | IntInf_lshift => intInfShift ()
+ | IntInf_mul => intInfBinary ()
+ | IntInf_neg => intInfUnary ()
+ | IntInf_notb => intInfUnary ()
+ | IntInf_orb => intInfBinary ()
+ | IntInf_quot => intInfBinary ()
+ | IntInf_rem => intInfBinary ()
+ | IntInf_sub => intInfBinary ()
+ | IntInf_toString => intInfToString ()
+ | IntInf_xorb => intInfBinary ()
| MLton_bug => CFunction.bug
| Thread_returnToC => CFunction.returnToC
- | Word_add s => wordBinary (s, "add")
- | Word_andb s => wordBinary (s, "andb")
- | Word_arshift s => wordShift (s, "arshift")
- | Word_div s => wordBinary (s, "div")
- | Word_equal s => wordCompare (s, "equal")
- | Word_ge s => wordCompare (s, "ge")
- | Word_gt s => wordCompare (s, "gt")
- | Word_le s => wordCompare (s, "le")
- | Word_lshift s => wordShift (s, "lshift")
- | Word_lt s => wordCompare (s, "lt")
- | Word_mod s => wordBinary (s, "mod")
- | Word_mul s => wordBinary (s, "mul")
- | Word_neg s => wordUnary (s, "neg")
- | Word_notb s => wordUnary (s, "notb")
- | Word_orb s => wordBinary (s, "orb")
- | Word_rol s => wordShift (s, "rol")
- | Word_ror s => wordShift (s, "ror")
- | Word_rshift s => wordShift (s, "rshift")
- | Word_sub s => wordBinary (s, "sub")
- | Word_toWord (s1, s2) => coerce (s1, wordC, s2, wordC)
- | Word_toWordX (s1, s2) => coerceX (s1, wordC, s2, wordC)
- | Word_xorb s => wordBinary (s, "xorb")
+ | Word_add s => wordBinary s
+ | Word_andb s => wordBinary s
+ | Word_equal s => wordCompare s
+ | Word_ge (s, _) => wordCompare s
+ | Word_gt (s, _) => wordCompare s
+ | Word_le (s, _) => wordCompare s
+ | Word_lshift s => wordShift s
+ | Word_lt (s, _) => wordCompare s
+ | Word_mul (s, _) => wordBinary s
+ | Word_neg s => wordUnary s
+ | Word_notb s => wordUnary s
+ | Word_orb s => wordBinary s
+ | Word_quot (s, _) => wordBinary s
+ | Word_rem (s, _) => wordBinary s
+ | Word_rol s => wordShift s
+ | Word_ror s => wordShift s
+ | Word_rshift (s, _) => wordShift s
+ | Word_sub s => wordBinary s
+ | Word_toReal (s1, s2, _) =>
+ coerce (Type.word (WordSize.bits s1), Type.real s2)
+ | Word_toWord (s1, s2, _) =>
+ coerce (Type.word (WordSize.bits s1),
+ Type.word (WordSize.bits s2))
+ | Word_xorb s => wordBinary s
| _ => raise Fail "cFunctionRaise"
end
fun cFunction n = SOME (cFunctionRaise n) handle _ => NONE
-
- fun cCodegenImplements n =
- let
- datatype z = datatype RealSize.t
- in
- case n of
- FFI_Symbol _ => true
- | Int_ge _ => true
- | Int_gt _ => true
- | Int_le _ => true
- | Int_lt _ => true
- | Int_mul _ => true
- | Int_toReal _ => true
- | Real_Math_acos _ => true
- | Real_Math_asin _ => true
- | Real_Math_atan _ => true
- | Real_Math_atan2 _ => true
- | Real_Math_cos _ => true
- | Real_Math_exp _ => true
- | Real_Math_ln _ => true
- | Real_Math_log10 _ => true
- | Real_Math_sin _ => true
- | Real_Math_sqrt _ => true
- | Real_Math_tan _ => true
- | Real_add _ => true
- | Real_div _ => true
- | Real_equal _ => true
- | Real_ge _ => true
- | Real_gt _ => true
- | Real_ldexp _ => true
- | Real_le _ => true
- | Real_lt _ => true
- | Real_mul _ => true
- | Real_muladd _ => true
- | Real_mulsub _ => true
- | Real_neg _ => true
- | Real_round _ => true
- | Real_sub _ => true
- | Real_toInt _ => true
- | Real_toReal _ => true
- | Thread_returnToC => true
- | Word_add _ => true
- | Word_andb _ => true
- | Word_arshift _ => true
- | Word_div _ => true
- | Word_equal _ => true
- | Word_ge _ => true
- | Word_gt _ => true
- | Word_le _ => true
- | Word_lshift _ => true
- | Word_lt _ => true
- | Word_mod _ => true
- | Word_mul _ => true
- | Word_neg _ => true
- | Word_notb _ => true
- | Word_orb _ => true
- | Word_rol _ => true
- | Word_ror _ => true
- | Word_rshift _ => true
- | Word_sub _ => true
- | Word_toWord _ => true
- | Word_toWordX _ => true
- | Word_xorb _ => true
- | _ => false
- end
-
- fun x86CodegenImplements n =
- let
- datatype z = datatype IntSize.prim
- datatype z = datatype RealSize.t
- datatype z = datatype WordSize.prim
- fun i32168 s =
- case IntSize.prim s of
- I8 => true
- | I16 => true
- | I32 => true
- | I64 => false
- fun w32168 s =
- case WordSize.prim s of
- W8 => true
- | W16 => true
- | W32 => true
- | W64 => false
- in
- case n of
- FFI_Symbol _ => true
- | Int_addCheck _ => true
- | Int_ge s => i32168 s
- | Int_gt s => i32168 s
- | Int_le s => i32168 s
- | Int_lt s => i32168 s
- | Int_mul s => i32168 s
- | Int_mulCheck s => i32168 s
- | Int_negCheck _ => true
- | Int_quot s => i32168 s
- | Int_rem s => i32168 s
- | Int_subCheck _ => true
- | Int_toReal (s1, s2) =>
- (case (IntSize.prim s1, s2) of
- (I32, R64) => true
- | (I32, R32) => true
- | (I16, R64) => true
- | (I16, R32) => true
- | (I8, R64) => true
- | (I8, R32) => true
- | _ => false)
- | Real_Math_acos _ => true
- | Real_Math_asin _ => true
- | Real_Math_atan _ => true
- | Real_Math_atan2 _ => true
- | Real_Math_cos _ => true
- | Real_Math_exp _ => true
- | Real_Math_ln _ => true
- | Real_Math_log10 _ => true
- | Real_Math_sin _ => true
- | Real_Math_sqrt _ => true
- | Real_Math_tan _ => true
- | Real_abs _ => true
- | Real_add _ => true
- | Real_div _ => true
- | Real_equal _ => true
- | Real_ge _ => true
- | Real_gt _ => true
- | Real_ldexp _ => true
- | Real_le _ => true
- | Real_lt _ => true
- | Real_mul _ => true
- | Real_muladd _ => true
- | Real_mulsub _ => true
- | Real_neg _ => true
- | Real_qequal _ => true
- | Real_round _ => true
- | Real_sub _ => true
- | Real_toInt (s1, s2) =>
- (case (s1, IntSize.prim s2) of
- (R64, I32) => true
- | (R64, I16) => true
- | (R64, I8) => true
- | (R32, I32) => true
- | (R32, I16) => true
- | (R32, I8) => true
- | _ => false)
- | Real_toReal _ => true
- | Word_add _ => true
- | Word_addCheck _ => true
- | Word_andb _ => true
- | Word_arshift s => w32168 s
- | Word_div s => w32168 s
- | Word_equal s => w32168 s
- | Word_ge s => w32168 s
- | Word_gt s => w32168 s
- | Word_le s => w32168 s
- | Word_lshift s => w32168 s
- | Word_lt s => w32168 s
- | Word_mod s => w32168 s
- | Word_mul s => w32168 s
- | Word_mulCheck s => w32168 s
- | Word_neg _ => true
- | Word_notb _ => true
- | Word_orb _ => true
- | Word_rol s => w32168 s
- | Word_ror s => w32168 s
- | Word_rshift s => w32168 s
- | Word_sub _ => true
- | Word_toWord (s1, s2) =>
- (case (WordSize.prim s1, WordSize.prim s2) of
- (W32, W32) => true
- | (W32, W16) => true
- | (W32, W8) => true
- | (W16, W32) => true
- | (W16, W16) => true
- | (W16, W8) => true
- | (W8, W32) => true
- | (W8, W16) => true
- | (W8, W8) => true
- | _ => false)
- | Word_toWordX (s1, s2) =>
- (case (WordSize.prim s1, WordSize.prim s2) of
- (W32, W32) => true
- | (W32, W16) => true
- | (W32, W8) => true
- | (W16, W32) => true
- | (W16, W16) => true
- | (W16, W8) => true
- | (W8, W32) => true
- | (W8, W16) => true
- | (W8, W8) => true
- | _ => false)
- | Word_xorb _ => true
- | _ => false
- end
-
- val x86CodegenImplements: t -> bool =
- Trace.trace ("x86CodegenImplements", layout, Bool.layout)
- x86CodegenImplements
end
datatype z = datatype Operand.t
@@ -564,7 +342,8 @@
(!Control.cardSizeLog2),
WordSize.default)))),
dst = SOME (index, indexTy),
- prim = Prim.wordRshift WordSize.default},
+ prim = Prim.wordRshift (WordSize.default,
+ {signed = false})},
Move {dst = (ArrayOffset
{base = Runtime GCField.CardMap,
index = Var {ty = indexTy, var = index},
@@ -619,40 +398,14 @@
datatype z = datatype Const.t
in
case c of
- Int i =>
- let
- val s = IntX.size i
- val s' = IntSize.roundUpToPrim s
- val i =
- if IntSize.equals (s, s')
- then i
- else
- (* Represent a twos-complement s-bit integer in a
- * twos-complement s'-bit integer. If the integer is
- * negative, to get the right bits, we need to make it
- * positive.
- *)
- let
- val i' = IntX.toIntInf i
- val i' =
- if i' >= 0
- then i'
- else
- i' - IntInf.<< (~1, Bits.toWord (IntSize.bits s))
- in
- IntX.make (i', s')
- end
- in
- Int i
- end
- | Word w => Word (WordX.resize (w, WordSize.roundUpToPrim (WordX.size w)))
+ Word w => Word (WordX.resize (w, WordSize.roundUpToPrim (WordX.size w)))
| _ => c
end
val word = Type.word o WordSize.bits
-fun convert (program as S.Program.T {functions, globals, main, ...})
- : Rssa.Program.t =
+fun convert (program as S.Program.T {functions, globals, main, ...},
+ {codegenImplementsPrim}): Rssa.Program.t =
let
val {conApp, diagnostic, genCase, objectTypes, reff, select, toRtype,
tuple} =
@@ -705,52 +458,40 @@
cases: S.Cases.t,
default: Label.t option})
: Statement.t list * Transfer.t =
- let
- fun simple (s, cs) =
+ case cases of
+ S.Cases.Con cases =>
+ (case (Vector.length cases, default) of
+ (0, NONE) => ([], Transfer.bug)
+ | _ =>
+ let
+ val (tycon, tys) = S.Type.tyconArgs (varType test)
+ in
+ if Vector.isEmpty tys
+ then
+ let
+ val test = fn () => varOp test
+ val (ss, t, blocks) =
+ genCase {cases = cases,
+ default = default,
+ test = test,
+ tycon = tycon}
+ val () =
+ extraBlocks := blocks @ !extraBlocks
+ in
+ (ss, t)
+ end
+ else Error.bug "strange type in case"
+ end)
+ | S.Cases.Word (s, cs) =>
([],
Switch
(Switch.T
{cases = (QuickSort.sortVector
- (cs, fn ((w, _), (w', _)) => WordX.<= (w, w'))),
+ (cs, fn ((w, _), (w', _)) =>
+ WordX.le (w, w', {signed = false}))),
default = default,
size = s,
test = varOp test}))
- in
- case cases of
- S.Cases.Con cases =>
- (case (Vector.length cases, default) of
- (0, NONE) => ([], Transfer.bug)
- | _ =>
- let
- val (tycon, tys) = S.Type.tyconArgs (varType test)
- in
- if Vector.isEmpty tys
- then
- let
- val test = fn () => varOp test
- val (ss, t, blocks) =
- genCase {cases = cases,
- default = default,
- test = test,
- tycon = tycon}
- val () =
- extraBlocks := blocks @ !extraBlocks
- in
- (ss, t)
- end
- else Error.bug "strange type in case"
- end)
- | S.Cases.Int (s, cs) =>
- let
- val s = WordSize.fromBits (IntSize.bits s)
- val cs = Vector.map (cs, fn (i, l) =>
- (WordX.fromIntInf (IntX.toIntInf i, s),
- l))
- in
- simple (s, cs)
- end
- | S.Cases.Word (s, cs) => simple (s, cs)
- end
val {get = labelInfo: (Label.t ->
{args: (Var.t * S.Type.t) vector,
cont: (Handler.t * Label.t) list ref,
@@ -916,7 +657,8 @@
in
case Type.dest t of
Constant w => c (Const.word w)
- | Pointer _ => Cast (Operand.int (IntX.one IntSize.default), t)
+ | Pointer _ =>
+ Cast (Operand.word (WordX.one (WordSize.pointer ())), t)
| Real s => c (Const.real (RealX.zero s))
| Sum ts => bogus (Vector.sub (ts, 0))
| Word s => c (Const.word (WordX.zero (WordSize.fromBits s)))
@@ -936,7 +678,7 @@
then (Vector.fromList ss, t)
else
let
- val S.Statement.T {exp, ty, var} =
+ val s as S.Statement.T {exp, ty, var} =
Vector.sub (statements, i)
fun none () = loop (i - 1, ss, t)
fun add s = loop (i - 1, s :: ss, t)
@@ -985,7 +727,7 @@
move (Offset
{base = a 0,
offset = Runtime.arrayLengthOffset,
- ty = Type.defaultInt})
+ ty = Type.defaultWord})
fun sub (ty: Type.t) =
let
val base = a 0
@@ -1137,13 +879,11 @@
in
loop (i - 1, ss, t)
end
- fun nativeOrC (p: Prim.t) =
+ fun codegenOrC (p: Prim.t) =
let
val n = Prim.name p
in
- if if !Control.Native.native
- then Name.x86CodegenImplements n
- else Name.cCodegenImplements n
+ if codegenImplementsPrim p
then primApp p
else (case Name.cFunction n of
NONE =>
@@ -1151,22 +891,6 @@
Name.toString n])
| SOME f => simpleCCall f)
end
- fun wordToWord (s1: WordSize.t, s2: WordSize.t) =
- if WordSize.equals (s1, s2)
- then move (a 0)
- else nativeOrC (Prim.wordToWord (s1, s2))
- fun wordToWordX (s1: WordSize.t, s2: WordSize.t) =
- if WordSize.equals (s1, s2)
- then move (a 0)
- else
- let
- val p =
- if Bits.< (WordSize.bits s1, WordSize.bits s2)
- then Prim.wordToWordX
- else Prim.wordToWord
- in
- nativeOrC (p (s1, s2))
- end
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
@@ -1219,8 +943,7 @@
ccall
{args = (Vector.new5
(GCState,
- Operand.int (IntX.zero
- IntSize.default),
+ Operand.zero WordSize.default,
Operand.bool true,
File,
Line)),
@@ -1232,33 +955,6 @@
| GC_unpack =>
ccall {args = Vector.new1 GCState,
func = CFunction.unpack}
- | Int_add s =>
- nativeOrC (Prim.wordAdd
- (intSizeToWordSize s))
- | Int_arshift s =>
- nativeOrC (Prim.wordArshift
- (intSizeToWordSize s))
- | Int_equal s =>
- nativeOrC (Prim.wordEqual
- (intSizeToWordSize
- (IntSize.roundUpToPrim s)))
- | Int_lshift s =>
- nativeOrC (Prim.wordLshift
- (intSizeToWordSize s))
- | Int_neg s =>
- nativeOrC (Prim.wordNeg
- (intSizeToWordSize s))
- | Int_sub s =>
- nativeOrC (Prim.wordSub
- (intSizeToWordSize s))
- | Int_toInt (s1, s2) =>
- wordToWordX
- (intSizeToWordSize
- (IntSize.roundUpToPrim s1),
- intSizeToWordSize
- (IntSize.roundUpToPrim s2))
- | Int_toWord (s1, s2) =>
- wordToWordX (intSizeToWordSize s1, s2)
| IntInf_toVector => cast ()
| IntInf_toWord => cast ()
| MLton_bogus =>
@@ -1269,7 +965,7 @@
(case targ () of
NONE => move (Operand.bool true)
| SOME t =>
- nativeOrC
+ codegenOrC
(Prim.wordEqual
(WordSize.fromBits (Type.width t))))
| MLton_installSignalHandler => none ()
@@ -1277,14 +973,12 @@
simpleCCall
(CFunction.size (Operand.ty (a 0)))
| MLton_touch => none ()
- | Pointer_getInt s => pointerGet (Type.int s)
| Pointer_getPointer =>
(case targ () of
NONE => Error.bug "getPointer"
| SOME t => pointerGet t)
| Pointer_getReal s => pointerGet (Type.real s)
| Pointer_getWord s => pointerGet (word s)
- | Pointer_setInt s => pointerSet (Type.int s)
| Pointer_setPointer =>
(case targ () of
NONE => Error.bug "setPointer"
@@ -1385,8 +1079,7 @@
val args =
Vector.new5
(GCState,
- Operand.int (IntX.zero
- IntSize.default),
+ Operand.zero WordSize.default,
Operand.bool false,
File,
Line)
@@ -1472,16 +1165,30 @@
end,
none)
| Word_equal s =>
- nativeOrC (Prim.wordEqual
+ codegenOrC (Prim.wordEqual
(WordSize.roundUpToPrim s))
- | Word_toInt (s1, s2) =>
- wordToWord (s1, intSizeToWordSize s2)
- | Word_toIntX (s1, s2) =>
- wordToWordX (s1, intSizeToWordSize s2)
- | Word_toIntInf => move (a 0)
- | Word_toWord (s1, s2) =>
- wordToWord (WordSize.roundUpToPrim s1,
- WordSize.roundUpToPrim s2)
+ | Word_toIntInf => cast ()
+ | Word_toWord (s1, s2, {signed}) =>
+ if WordSize.equals (s1, s2)
+ then move (a 0)
+ else
+ let
+ val signed =
+ signed
+ andalso Bits.< (WordSize.bits s1,
+ WordSize.bits s2)
+ val b1 = WordSize.bits s1
+ val b2 = WordSize.bits s2
+ val s1 = WordSize.roundUpToPrim s1
+ val s2 = WordSize.roundUpToPrim s2
+ in
+ if WordSize.equals (s1, s2)
+ then cast ()
+ else
+ codegenOrC
+ (Prim.wordToWord
+ (s1, s2, {signed = signed}))
+ end
| WordVector_toIntInf => move (a 0)
| Word8Array_subWord => subWord ()
| Word8Array_updateWord =>
@@ -1496,7 +1203,7 @@
(GCState,
Vector.sub (vos args, 0))),
func = CFunction.worldSave}
- | _ => nativeOrC prim
+ | _ => codegenOrC prim
end
| S.Exp.Profile e => add (Statement.Profile e)
| S.Exp.Select {tuple, offset} =>
1.11 +4 -1 mlton/mlton/backend/ssa-to-rssa.sig
Index: ssa-to-rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- ssa-to-rssa.sig 28 Apr 2004 03:17:05 -0000 1.10
+++ ssa-to-rssa.sig 1 May 2004 00:49:35 -0000 1.11
@@ -24,5 +24,8 @@
sig
include SSA_TO_RSSA_STRUCTS
- val convert: Ssa.Program.t -> Rssa.Program.t
+ val convert:
+ Ssa.Program.t
+ * {codegenImplementsPrim: Rssa.Type.t Rssa.Prim.t -> bool}
+ -> Rssa.Program.t
end
1.8 +2 -1 mlton/mlton/backend/switch.fun
Index: switch.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/switch.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- switch.fun 23 Apr 2004 06:15:56 -0000 1.7
+++ switch.fun 1 May 2004 00:49:35 -0000 1.8
@@ -59,7 +59,8 @@
andalso (case default of
NONE => true
| SOME l => labelIsOk l)
- andalso Vector.isSorted (cases, fn ((w, _), (w', _)) => WordX.<= (w, w'))
+ andalso Vector.isSorted (cases, fn ((w, _), (w', _)) =>
+ WordX.le (w, w', {signed = false}))
andalso not (isRedundant
{cases = cases,
equals = fn ((w, _), (w', _)) => WordX.equals (w, w')})
1.35 +2 -4 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.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- closure-convert.fun 12 Apr 2004 17:52:59 -0000 1.34
+++ closure-convert.fun 1 May 2004 00:49:36 -0000 1.35
@@ -798,7 +798,6 @@
end)
in (finish cases, ac)
end
- fun doit (l, f) = doCases (l, f, fn i => fn e => (i, e))
val (cases, ac) =
case cases of
Scases.Con cases =>
@@ -817,10 +816,9 @@
body = body,
con = con}
end)
- | Scases.Int (s, cs) =>
- doit (cs, fn cs => Dexp.Int (s, cs))
| Scases.Word (s, cs) =>
- doit (cs, fn cs => Dexp.Word (s, cs))
+ doCases (cs, fn cs => Dexp.Word (s, cs),
+ fn i => fn e => (i, e))
in (Dexp.casee
{test = convertVarExp test,
ty = ty, cases = cases, default = default},
1.79 +66 -44 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.78
retrieving revision 1.79
diff -u -r1.78 -r1.79
--- c-codegen.fun 13 Apr 2004 15:40:19 -0000 1.78
+++ c-codegen.fun 1 May 2004 00:49:36 -0000 1.79
@@ -23,7 +23,6 @@
structure FrameInfo = FrameInfo
structure Global = Global
structure IntSize = IntSize
- structure IntX = IntX
structure Kind = Kind
structure Label = Label
structure ObjectType = ObjectType
@@ -93,34 +92,6 @@
val traceGotoLabel = Trace.trace ("gotoLabel", Label.layout, Unit.layout)
-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 ()
- datatype z = datatype IntSize.prim
- in
- case IntSize.prim (size i) of
- I8 => simple "8"
- | I16 => simple "16"
- | I32 => tricky ("0x80000000")
- | I64 => concat [tricky "0x8000000000000000", "ll"]
- end
- end
-
structure RealX =
struct
open RealX
@@ -182,7 +153,9 @@
; print ";\n")
fun int (i: int) =
- IntX.toC (IntX.make (IntInf.fromInt i, IntSize.default))
+ if i >= 0
+ then Int.toString i
+ else concat ["-", Int.toString (~ i)]
val bytes = int o Bytes.toInt
@@ -211,6 +184,64 @@
| _ => false
end
+fun implementsPrim (p: 'a Prim.t): bool =
+ let
+ datatype z = datatype Prim.Name.t
+ in
+ case Prim.name p of
+ FFI_Symbol _ => true
+ | Real_Math_acos _ => true
+ | Real_Math_asin _ => true
+ | Real_Math_atan _ => true
+ | Real_Math_atan2 _ => true
+ | Real_Math_cos _ => true
+ | Real_Math_exp _ => true
+ | Real_Math_ln _ => true
+ | Real_Math_log10 _ => true
+ | Real_Math_sin _ => true
+ | Real_Math_sqrt _ => true
+ | Real_Math_tan _ => true
+ | Real_add _ => true
+ | Real_div _ => true
+ | Real_equal _ => true
+ | Real_ge _ => true
+ | Real_gt _ => true
+ | Real_ldexp _ => true
+ | Real_le _ => true
+ | Real_lt _ => true
+ | Real_mul _ => true
+ | Real_muladd _ => true
+ | Real_mulsub _ => true
+ | Real_neg _ => true
+ | Real_round _ => true
+ | Real_sub _ => true
+ | Real_toReal _ => true
+ | Real_toWord _ => true
+ | Thread_returnToC => true
+ | Word_add _ => true
+ | Word_andb _ => true
+ | Word_equal _ => true
+ | Word_ge _ => true
+ | Word_gt _ => true
+ | Word_le _ => true
+ | Word_lshift _ => true
+ | Word_lt _ => true
+ | Word_mul _ => true
+ | Word_neg _ => true
+ | Word_notb _ => true
+ | Word_orb _ => true
+ | Word_quot (_, {signed}) => not signed
+ | Word_rem (_, {signed}) => not signed
+ | Word_rol _ => true
+ | Word_ror _ => true
+ | Word_rshift _ => true
+ | Word_sub _ => true
+ | Word_toReal _ => true
+ | Word_toWord _ => true
+ | Word_xorb _ => true
+ | _ => false
+ end
+
fun creturn (t: Type.t): string =
concat ["CReturn", CType.name (Type.toCType t)]
@@ -551,7 +582,6 @@
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} =>
@@ -918,36 +948,28 @@
datatype z = datatype Prim.Name.t
fun const i =
case Vector.sub (args, i) of
- Operand.Int _ => true
+ Operand.Word _ => true
| _ => false
fun const0 () = const 0
fun const1 () = const 1
in
case Prim.name prim of
- 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 _ =>
+ Word_addCheck _ =>
concat [Prim.toString prim,
if const0 ()
then "CX"
else if const1 ()
then "XC"
else ""]
- | Word_addCheck _ =>
+ | Word_mulCheck _ => Prim.toString prim
+ | Word_negCheck _ => Prim.toString prim
+ | Word_subCheck _ =>
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
1.12 +1 -0 mlton/mlton/codegen/c-codegen/c-codegen.sig
Index: c-codegen.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- c-codegen.sig 4 Apr 2004 06:50:18 -0000 1.11
+++ c-codegen.sig 1 May 2004 00:49:36 -0000 1.12
@@ -16,6 +16,7 @@
sig
include C_CODEGEN_STRUCTS
+ val implementsPrim: 'a Machine.Prim.t -> bool
val output: {program: Machine.Program.t,
outputC: unit -> {file: File.t,
print: string -> unit,
1.55 +2 -0 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.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- x86-codegen.fun 25 Apr 2004 06:55:45 -0000 1.54
+++ x86-codegen.fun 1 May 2004 00:49:38 -0000 1.55
@@ -33,6 +33,8 @@
= x86MLton (structure x86MLtonBasic = x86MLtonBasic
structure x86Liveness = x86Liveness)
+ val implementsPrim = x86MLton.implementsPrim
+
structure x86Translate
= x86Translate (structure x86 = x86
structure x86MLton = x86MLton
1.11 +11 -11 mlton/mlton/codegen/x86-codegen/x86-codegen.sig
Index: x86-codegen.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-codegen.sig 4 Apr 2004 06:50:19 -0000 1.10
+++ x86-codegen.sig 1 May 2004 00:49:38 -0000 1.11
@@ -13,16 +13,16 @@
end
signature X86_CODEGEN =
- sig
- include X86_CODEGEN_STRUCTS
+ sig
+ include X86_CODEGEN_STRUCTS
- val output: {program: Machine.Program.t,
- outputC: unit -> {file: File.t,
- print: string -> unit,
- done: unit -> unit},
- outputS: unit -> {file: File.t,
- print: string -> unit,
- done: unit -> unit}}
- -> unit
- end
+ val implementsPrim: Machine.Type.t Machine.Prim.t -> bool
+ val output: {program: Machine.Program.t,
+ outputC: unit -> {file: File.t,
+ print: string -> unit,
+ done: unit -> unit},
+ outputS: unit -> {file: File.t,
+ print: string -> unit,
+ done: unit -> unit}} -> unit
+ end
1.60 +312 -313 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.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- x86-mlton.fun 25 Apr 2004 22:02:50 -0000 1.59
+++ x86-mlton.fun 1 May 2004 00:49:39 -0000 1.60
@@ -1,11 +1,12 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor x86MLton(S: X86_MLTON_STRUCTS): X86_MLTON =
+
+functor x86MLton (S: X86_MLTON_STRUCTS): X86_MLTON =
struct
open S
@@ -16,9 +17,9 @@
in
structure CFunction = CFunction
structure IntSize = IntSize
+ structure RealSize = RealSize
structure Prim = Prim
structure WordSize = WordSize
- datatype z = datatype IntSize.prim
datatype z = datatype RealSize.t
datatype z = datatype WordSize.prim
end
@@ -29,6 +30,108 @@
live: x86.Label.t -> x86.Operand.t list,
liveInfo: x86Liveness.LiveInfo.t}
+ fun implementsPrim (p: 'a Prim.t) =
+ let
+ datatype z = datatype IntSize.prim
+ datatype z = datatype RealSize.t
+ datatype z = datatype WordSize.prim
+ fun w32168 s =
+ case WordSize.prim s of
+ W8 => true
+ | W16 => true
+ | W32 => true
+ | W64 => false
+ datatype z = datatype Prim.Name.t
+ in
+ case Prim.name p of
+ FFI_Symbol _ => true
+ | Real_Math_acos _ => true
+ | Real_Math_asin _ => true
+ | Real_Math_atan _ => true
+ | Real_Math_atan2 _ => true
+ | Real_Math_cos _ => true
+ | Real_Math_exp _ => true
+ | Real_Math_ln _ => true
+ | Real_Math_log10 _ => true
+ | Real_Math_sin _ => true
+ | Real_Math_sqrt _ => true
+ | Real_Math_tan _ => true
+ | Real_abs _ => true
+ | Real_add _ => true
+ | Real_div _ => true
+ | Real_equal _ => true
+ | Real_ge _ => true
+ | Real_gt _ => true
+ | Real_ldexp _ => true
+ | Real_le _ => true
+ | Real_lt _ => true
+ | Real_mul _ => true
+ | Real_muladd _ => true
+ | Real_mulsub _ => true
+ | Real_neg _ => true
+ | Real_qequal _ => true
+ | Real_round _ => true
+ | Real_sub _ => true
+ | Real_toReal _ => true
+ | Real_toWord (s1, s2, {signed}) =>
+ signed
+ andalso (case (s1, WordSize.prim s2) of
+ (R64, W32) => true
+ | (R64, W16) => true
+ | (R64, W8) => true
+ | (R32, W32) => true
+ | (R32, W16) => true
+ | (R32, W8) => true
+ | _ => false)
+ | Word_add _ => true
+ | Word_addCheck _ => true
+ | Word_andb _ => true
+ | Word_equal s => w32168 s
+ | Word_ge (s, _) => w32168 s
+ | Word_gt (s, _) => w32168 s
+ | Word_le (s, _) => w32168 s
+ | Word_lshift s => w32168 s
+ | Word_lt (s, _) => w32168 s
+ | Word_mul (s, _) => w32168 s
+ | Word_mulCheck (s, _) => w32168 s
+ | Word_neg _ => true
+ | Word_notb _ => true
+ | Word_orb _ => true
+ | Word_quot (s, _) => w32168 s
+ | Word_rem (s, _) => w32168 s
+ | Word_rol s => w32168 s
+ | Word_ror s => w32168 s
+ | Word_rshift (s, _) => w32168 s
+ | Word_sub _ => true
+ | Word_toReal (s1, s2, {signed}) =>
+ signed
+ andalso (case (WordSize.prim s1, s2) of
+ (W32, R64) => true
+ | (W32, R32) => true
+ | (W16, R64) => true
+ | (W16, R32) => true
+ | (W8, R64) => true
+ | (W8, R32) => true
+ | _ => false)
+ | Word_toWord (s1, s2, _) =>
+ (case (WordSize.prim s1, WordSize.prim s2) of
+ (W32, W32) => true
+ | (W32, W16) => true
+ | (W32, W8) => true
+ | (W16, W32) => true
+ | (W16, W16) => true
+ | (W16, W8) => true
+ | (W8, W32) => true
+ | (W8, W16) => true
+ | (W8, W8) => true
+ | _ => false)
+ | Word_xorb _ => true
+ | _ => false
+ end
+
+ val implementsPrim: Machine.Type.t Prim.t -> bool =
+ Trace.trace ("implementsPrim", Prim.layout, Bool.layout) implementsPrim
+
fun prim {prim : RepType.t Prim.t,
args : (Operand.t * Size.t) vector,
dsts : (Operand.t * Size.t) vector,
@@ -575,6 +678,28 @@
transfer = NONE}))
end
else (AppendList.empty,AppendList.empty)
+ fun bitop (size, i) =
+ case WordSize.prim size of
+ W8 => binal i
+ | W16 => binal i
+ | W32 => binal i
+ | W64 => binal64 (i, i)
+ fun compare (size, {signed}, s, u) =
+ let
+ val f = if signed then s else u
+ in
+ case WordSize.prim size of
+ W8 => cmp f
+ | W16 => cmp f
+ | W32 => cmp f
+ | W64 => Error.bug "FIXME"
+ end
+ fun shift (size, i) =
+ case WordSize.prim size of
+ W8 => sral i
+ | W16 => sral i
+ | W32 => sral i
+ | W64 => Error.bug "FIXME"
in
AppendList.appends
[comment_begin,
@@ -606,101 +731,6 @@
| _ => Error.bug "prim: FFI"],
transfer = NONE}]
end
- | Int_ge s =>
- (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 IntSize.prim s of
- I8 => cmp Instruction.G
- | I16 => cmp Instruction.G
- | I32 => cmp Instruction.G
- | I64 => Error.bug "FIXME")
- | Int_le s =>
- (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 IntSize.prim s of
- I8 => cmp Instruction.L
- | I16 => cmp Instruction.L
- | I32 => cmp Instruction.L
- | I64 => Error.bug "FIXME")
- | Int_mul s =>
- (case IntSize.prim s of
- I8 => pmd Instruction.IMUL
- | I16 => imul2 ()
- | I32 => imul2 ()
- | I64 => Error.bug "FIXME")
- | Int_quot s =>
- (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 IntSize.prim s of
- I8 => pmd Instruction.IMOD
- | I16 => pmd Instruction.IMOD
- | I32 => pmd Instruction.IMOD
- | I64 => Error.bug "FIXME")
- | Int_toReal (s, s')
- => let
- fun default () =
- let
- val (dst,dstsize) = getDst1 ()
- val (src,srcsize) = getSrc1 ()
- in
- AppendList.fromList
- [Block.mkBlock'
- {entry = NONE,
- statements
- = [Assembly.instruction_pfmovfi
- {src = src,
- dst = dst,
- srcsize = srcsize,
- dstsize = dstsize}],
- transfer = NONE}]
- end
- fun default' () =
- let
- val (dst,dstsize) = getDst1 ()
- val (src,srcsize) = getSrc1 ()
- val (tmp,tmpsize) =
- (fildTempContentsOperand, Size.WORD)
- in
- AppendList.fromList
- [Block.mkBlock'
- {entry = NONE,
- statements
- = [Assembly.instruction_movx
- {oper = Instruction.MOVSX,
- src = src,
- dst = tmp,
- dstsize = tmpsize,
- srcsize = srcsize},
- Assembly.instruction_pfmovfi
- {src = tmp,
- dst = dst,
- srcsize = tmpsize,
- dstsize = dstsize}],
- transfer = NONE}]
- end
- in
- case (IntSize.prim s, s') of
- (I64, R64) => Error.bug "FIXME"
- | (I64, R32) => Error.bug "FIXME"
- | (I32, R64) => default ()
- | (I32, R32) => default ()
- | (I16, R64) => default ()
- | (I16, R32) => default ()
- | (I8, R64) => default' ()
- | (I8, R32) => default' ()
- end
| Real_Math_acos _
=> let
val (dst,dstsize) = getDst1 ()
@@ -1139,58 +1169,6 @@
transfer = NONE}]
end
| Real_abs _ => funa Instruction.FABS
- | Real_toInt (s, s')
- => let
- fun default () =
- let
- val (dst,dstsize) = getDst1 ()
- val (src,srcsize) = getSrc1 ()
- in
- AppendList.fromList
- [Block.mkBlock'
- {entry = NONE,
- statements
- = [Assembly.instruction_pfmovti
- {dst = dst,
- src = src,
- srcsize = srcsize,
- dstsize = dstsize}],
- transfer = NONE}]
- end
- fun default' () =
- let
- val (dst,dstsize) = getDst1 ()
- val (src,srcsize) = getSrc1 ()
- val (tmp,tmpsize) =
- (fildTempContentsOperand, Size.WORD)
- in
- AppendList.fromList
- [Block.mkBlock'
- {entry = NONE,
- statements
- = [Assembly.instruction_pfmovti
- {dst = dst,
- src = src,
- srcsize = srcsize,
- dstsize = dstsize},
- Assembly.instruction_xvom
- {src = tmp,
- dst = dst,
- dstsize = dstsize,
- srcsize = tmpsize}],
- transfer = NONE}]
- end
- in
- case (s, IntSize.prim s') of
- (R64, I64) => Error.bug "FIXME"
- | (R64, I32) => default ()
- | (R64, I16) => default ()
- | (R64, I8) => default' ()
- | (R32, I64) => Error.bug "FIXME"
- | (R32, I32) => default ()
- | (R32, I16) => default ()
- | (R32, I8) => default' ()
- end
| Real_toReal (s, s')
=> let
val (dst,dstsize) = getDst1 ()
@@ -1234,6 +1212,58 @@
| (R32, R64) => movx ()
| (R32, R32) => mov ()
end
+ | Real_toWord (s, s', _)
+ => let
+ fun default () =
+ let
+ val (dst,dstsize) = getDst1 ()
+ val (src,srcsize) = getSrc1 ()
+ in
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [Assembly.instruction_pfmovti
+ {dst = dst,
+ src = src,
+ srcsize = srcsize,
+ dstsize = dstsize}],
+ transfer = NONE}]
+ end
+ fun default' () =
+ let
+ val (dst,dstsize) = getDst1 ()
+ val (src,srcsize) = getSrc1 ()
+ val (tmp,tmpsize) =
+ (fildTempContentsOperand, Size.WORD)
+ in
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [Assembly.instruction_pfmovti
+ {dst = dst,
+ src = src,
+ srcsize = srcsize,
+ dstsize = dstsize},
+ Assembly.instruction_xvom
+ {src = tmp,
+ dst = dst,
+ dstsize = dstsize,
+ srcsize = tmpsize}],
+ transfer = NONE}]
+ end
+ in
+ case (s, WordSize.prim s') of
+ (R64, W64) => Error.bug "FIXME"
+ | (R64, W32) => default ()
+ | (R64, W16) => default ()
+ | (R64, W8) => default' ()
+ | (R32, W64) => Error.bug "FIXME"
+ | (R32, W32) => default ()
+ | (R32, W16) => default ()
+ | (R32, W8) => default' ()
+ end
| Real_ldexp _
=> let
val (dst,dstsize) = getDst1 ()
@@ -1277,69 +1307,18 @@
| W16 => binal Instruction.ADD
| W32 => binal Instruction.ADD
| W64 => binal64 (Instruction.ADD, Instruction.ADC))
- | Word_andb s =>
- (case WordSize.prim s of
- W8 => binal Instruction.AND
- | W16 => binal Instruction.AND
- | W32 => binal Instruction.AND
- | W64 => binal64 (Instruction.AND, Instruction.AND))
- | Word_arshift s =>
- (case WordSize.prim s of
- W8 => sral Instruction.SAR
- | W16 => sral Instruction.SAR
- | W32 => sral Instruction.SAR
- | W64 => Error.bug "FIXME")
- | Word_div s =>
- (case WordSize.prim s of
- W8 => pmd Instruction.DIV
- | W16 => pmd Instruction.DIV
- | W32 => pmd Instruction.DIV
- | W64 => Error.bug "FIXME")
- | Word_equal s =>
- (case WordSize.prim s of
- W8 => cmp Instruction.E
- | W16 => cmp Instruction.E
- | W32 => cmp Instruction.E
- | W64 => Error.bug "FIXME")
- | Word_ge s =>
- (case WordSize.prim s of
- W8 => cmp Instruction.AE
- | W16 => cmp Instruction.AE
- | W32 => cmp Instruction.AE
- | W64 => Error.bug "FIXME")
- | Word_gt s =>
- (case WordSize.prim s of
- W8 => cmp Instruction.A
- | W16 => cmp Instruction.A
- | W32 => cmp Instruction.A
- | W64 => Error.bug "FIXME")
- | Word_le s =>
- (case WordSize.prim s of
- W8 => cmp Instruction.BE
- | W16 => cmp Instruction.BE
- | W32 => cmp Instruction.BE
- | W64 => Error.bug "FIXME")
- | Word_lshift s =>
- (case WordSize.prim s of
- W8 => sral Instruction.SHL
- | W16 => sral Instruction.SHL
- | W32 => sral Instruction.SHL
- | W64 => Error.bug "FIXME")
- | Word_lt s =>
- (case WordSize.prim s of
- W8 => cmp Instruction.B
- | W16 => cmp Instruction.B
- | W32 => cmp Instruction.B
- | W64 => Error.bug "FIXME")
- | Word_mod s =>
- (case WordSize.prim s of
- W8 => pmd Instruction.MOD
- | W16 => pmd Instruction.MOD
- | W32 => pmd Instruction.MOD
- | W64 => Error.bug "FIXME")
- | Word_mul s =>
+ | Word_andb s => bitop (s, Instruction.AND)
+ | Word_equal s => cmp Instruction.E
+ | Word_ge (s, sg) => compare (s, sg, Instruction.GE, Instruction.AE)
+ | Word_gt (s, sg) => compare (s, sg, Instruction.G, Instruction.A)
+ | Word_le (s, sg) => compare (s, sg, Instruction.LE, Instruction.BE)
+ | Word_lshift s => shift (s, Instruction.SHL)
+ | Word_lt (s, sg) => compare (s, sg, Instruction.L, Instruction.B)
+ | Word_mul (s, {signed}) =>
(case WordSize.prim s of
- W8 => pmd Instruction.MUL
+ W8 => pmd (if signed
+ then Instruction.IMUL
+ else Instruction.MUL)
| W16 => imul2 ()
| W32 => imul2 ()
| W64 => Error.bug "FIXME")
@@ -1360,78 +1339,87 @@
| W16 => unal Instruction.NOT
| W32 => unal Instruction.NOT
| W64 => unal64 (Instruction.NOT, fn _ => []))
- | Word_orb s =>
- (case WordSize.prim s of
- W8 => binal Instruction.OR
- | W16 => binal Instruction.OR
- | W32 => binal Instruction.OR
- | W64 => binal64 (Instruction.OR, Instruction.OR))
- | Word_rol s =>
- (case WordSize.prim s of
- W8 => sral Instruction.ROL
- | W16 => sral Instruction.ROL
- | W32 => sral Instruction.ROL
- | W64 => Error.bug "FIXME")
- | Word_ror s =>
- (case WordSize.prim s of
- W8 => sral Instruction.ROR
- | W16 => sral Instruction.ROR
- | W32 => sral Instruction.ROR
- | W64 => Error.bug "FIXME")
- | Word_rshift s =>
- (case WordSize.prim s of
- W8 => sral Instruction.SHR
- | W16 => sral Instruction.SHR
- | W32 => sral Instruction.SHR
- | W64 => Error.bug "FIXME")
+ | Word_orb s => bitop (s, Instruction.OR)
+ | Word_quot (s, {signed}) =>
+ pmd (if signed then Instruction.IDIV else Instruction.DIV)
+ | Word_rem (s, {signed}) =>
+ pmd (if signed then Instruction.IMOD else Instruction.MOD)
+ | Word_rol s => shift (s, Instruction.ROL)
+ | Word_ror s => shift (s, Instruction.ROR)
+ | Word_rshift (s, {signed}) =>
+ shift (s, if signed then Instruction.SAR else Instruction.SHR)
| Word_sub s =>
(case WordSize.prim s of
W8 => binal Instruction.SUB
| W16 => binal Instruction.SUB
| W32 => binal Instruction.SUB
| W64 => binal64 (Instruction.SUB, Instruction.SBB))
- | Word_toWord (s, s') =>
- (case (WordSize.prim s, WordSize.prim s') of
- (W64, W64) => Error.bug "FIXME"
- | (W64, W32) => Error.bug "FIXME"
- | (W64, W16) => Error.bug "FIXME"
- | (W64, W8) => Error.bug "FIXME"
- | (W32, W64) => Error.bug "FIXME"
- | (W32, W32) => mov ()
- | (W32, W16) => xvom ()
- | (W32, W8) => xvom ()
- | (W16, W64) => Error.bug "FIXME"
- | (W16, W32) => movx Instruction.MOVZX
- | (W16, W16) => mov ()
- | (W16, W8) => xvom ()
- | (W8, W64) => Error.bug "FIXME"
- | (W8, W32) => movx Instruction.MOVZX
- | (W8, W16) => movx Instruction.MOVZX
- | (W8, W8) => mov ())
- | Word_toWordX (s, s') =>
- (case (WordSize.prim s, WordSize.prim s') of
- (W64, W64) => Error.bug "FIXME"
- | (W64, W32) => Error.bug "FIXME"
- | (W64, W16) => Error.bug "FIXME"
- | (W64, W8) => Error.bug "FIXME"
- | (W32, W64) => Error.bug "FIXME"
- | (W32, W32) => mov ()
- | (W32, W16) => xvom ()
- | (W32, W8) => xvom ()
- | (W16, W64) => Error.bug "FIXME"
- | (W16, W32) => movx Instruction.MOVSX
- | (W16, W16) => mov ()
- | (W16, W8) => xvom ()
- | (W8, W64) => Error.bug "FIXME"
- | (W8, W32) => movx Instruction.MOVSX
- | (W8, W16) => movx Instruction.MOVSX
- | (W8, W8) => mov ())
- | Word_xorb s =>
- (case WordSize.prim s of
- W8 => binal Instruction.XOR
- | W16 => binal Instruction.XOR
- | W32 => binal Instruction.XOR
- | W64 => binal64 (Instruction.XOR, Instruction.XOR))
+ | Word_toReal (s, s', {signed})
+ => let
+ fun default () =
+ let
+ val (dst,dstsize) = getDst1 ()
+ val (src,srcsize) = getSrc1 ()
+ in
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [Assembly.instruction_pfmovfi
+ {src = src,
+ dst = dst,
+ srcsize = srcsize,
+ dstsize = dstsize}],
+ transfer = NONE}]
+ end
+ fun default' () =
+ let
+ val (dst,dstsize) = getDst1 ()
+ val (src,srcsize) = getSrc1 ()
+ val (tmp,tmpsize) =
+ (fildTempContentsOperand, Size.WORD)
+ in
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [Assembly.instruction_movx
+ {oper = Instruction.MOVSX,
+ src = src,
+ dst = tmp,
+ dstsize = tmpsize,
+ srcsize = srcsize},
+ Assembly.instruction_pfmovfi
+ {src = tmp,
+ dst = dst,
+ srcsize = tmpsize,
+ dstsize = dstsize}],
+ transfer = NONE}]
+ end
+ in
+ case (WordSize.prim s, s') of
+ (W32, R64) => default ()
+ | (W32, R32) => default ()
+ | (W16, R64) => default ()
+ | (W16, R32) => default ()
+ | (W8, R64) => default' ()
+ | (W8, R32) => default' ()
+ | _ => Error.bug "FIXME"
+ end
+ | Word_toWord (s, s', {signed}) =>
+ let
+ val b = WordSize.bits s
+ val b' = WordSize.bits s'
+ in
+ if Bits.< (b, b')
+ then movx (if signed
+ then Instruction.MOVSX
+ else Instruction.MOVZX)
+ else if Bits.equals (b, b')
+ then mov ()
+ else xvom ()
+ end
+ | Word_xorb s => bitop (s, Instruction.XOR)
| _ => Error.bug ("prim: strange Prim.Name.t: " ^ primName)),
comment_end]
end
@@ -1778,46 +1766,57 @@
transfer = NONE}))
end
else (AppendList.empty,AppendList.empty)
+ fun flag {signed} =
+ if signed then x86.Instruction.O else x86.Instruction.C
in
AppendList.appends
[comment_begin,
(case Prim.name prim of
- Int_addCheck s =>
- (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 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 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 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)
- | I64 => neg64 ())
- | Word_addCheck s =>
- (case WordSize.prim s of
- W8 => binal (x86.Instruction.ADD, x86.Instruction.C)
- | W16 => binal (x86.Instruction.ADD, x86.Instruction.C)
- | W32 => binal (x86.Instruction.ADD, x86.Instruction.C)
- | W64 => binal64 (x86.Instruction.ADD, x86.Instruction.ADC, x86.Instruction.C))
- | Word_mulCheck s =>
+ Word_addCheck (s, sg) =>
+ let
+ val flag = flag sg
+ in
+ case WordSize.prim s of
+ W8 => binal (x86.Instruction.ADD, flag)
+ | W16 => binal (x86.Instruction.ADD, flag)
+ | W32 => binal (x86.Instruction.ADD, flag)
+ | W64 =>
+ binal64 (x86.Instruction.ADD, x86.Instruction.ADC, flag)
+ end
+ | Word_mulCheck (s, {signed}) =>
+ let
+ in
+ if signed
+ then
+ (case WordSize.prim s of
+ W8 => pmd (x86.Instruction.IMUL, x86.Instruction.O)
+ | W16 => imul2 x86.Instruction.O
+ | W32 => imul2 x86.Instruction.O
+ | W64 => Error.bug "FIXME")
+ else
+ (case WordSize.prim s of
+ W8 => pmd (x86.Instruction.MUL, x86.Instruction.C)
+ | W16 => pmd (x86.Instruction.MUL, x86.Instruction.C)
+ | W32 => pmd (x86.Instruction.MUL, x86.Instruction.C)
+ | W64 => Error.bug "FIXME")
+ end
+ | Word_negCheck s =>
(case WordSize.prim s of
- W8 => pmd (x86.Instruction.MUL, x86.Instruction.C)
- | W16 => pmd (x86.Instruction.MUL, x86.Instruction.C)
- | W32 => pmd (x86.Instruction.MUL, x86.Instruction.C)
- | W64 => Error.bug "FIXME")
+ W8 => unal (x86.Instruction.NEG, x86.Instruction.O)
+ | W16 => unal (x86.Instruction.NEG, x86.Instruction.O)
+ | W32 => unal (x86.Instruction.NEG, x86.Instruction.O)
+ | W64 => neg64 ())
+ | Word_subCheck (s, {signed}) =>
+ let
+ val flag =
+ if signed then x86.Instruction.O else x86.Instruction.C
+ in
+ case WordSize.prim s of
+ W8 => binal (x86.Instruction.SUB, flag)
+ | W16 => binal (x86.Instruction.SUB, flag)
+ | W32 => binal (x86.Instruction.SUB, flag)
+ | W64 => binal64 (x86.Instruction.SUB, x86.Instruction.SBB, flag)
+ end
| _ => Error.bug ("arith: strange Prim.Name.t: " ^ primName))]
end
1.18 +2 -1 mlton/mlton/codegen/x86-codegen/x86-mlton.sig
Index: x86-mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.sig,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- x86-mlton.sig 12 Apr 2004 17:53:01 -0000 1.17
+++ x86-mlton.sig 1 May 2004 00:49:39 -0000 1.18
@@ -44,7 +44,8 @@
func: RepType.t Machine.CFunction.t,
label: x86.Label.t,
transInfo: transInfo} -> x86.Block.t' AppendList.t
- val prim: {prim: RepType.t Machine.Prim.t,
+ val implementsPrim: RepType.t Machine.Prim.t -> bool
+ val prim: {prim: RepType.t Machine.Prim.t,
args: (x86.Operand.t * x86.Size.t) vector,
dsts: (x86.Operand.t * x86.Size.t) vector,
transInfo: transInfo} -> x86.Block.t' AppendList.t
1.58 +0 -81 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.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- x86-translate.fun 13 Apr 2004 15:40:19 -0000 1.57
+++ x86-translate.fun 1 May 2004 00:49:39 -0000 1.58
@@ -22,8 +22,6 @@
local
open Machine
in
- structure IntSize = IntSize
- structure IntX = IntX
structure Label = Label
structure Register = Register
structure Type = Type
@@ -163,85 +161,6 @@
Vector.new1 (x86.Operand.label x86MLton.gcState_label,
x86MLton.pointerSize)
| Global g => Global.toX86Operand g
- | Int i =>
- let
- val i'' = fn () => x86.Operand.immediate_const_int (IntX.toInt i)
- datatype z = datatype IntSize.prim
- in
- 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)
- | I64 => let
- fun convert1 (ii: IntInf.t): Word.t * Word.t =
- let
- val lo = Word.fromIntInf ii
- val ii = IntInf.~>> (ii, 0w32)
- val hi = Word.fromIntInf ii
- in
- (lo, hi)
- end
- fun convert2 (ii: IntInf.t): Word.t * Word.t =
- let
- fun finish (iis: String.t, c: Char.t) =
- let
- val s =
- String.concat
- [String.tabulate
- (16 - String.size iis, fn _ => c),
- iis]
- fun cvt s = valOf (Word.fromString s)
- val lo = cvt(String.extract(s, 8, SOME 8))
- val hi = cvt(String.extract(s, 0, SOME 8))
- in
- (lo, hi)
- end
- in
- if ii < 0
- then let
- val ii = ~ ii - 1
- val iis =
- String.translate
- (IntInf.format (ii, StringCvt.HEX),
- fn #"0" => "F"
- | #"1" => "E"
- | #"2" => "D"
- | #"3" => "C"
- | #"4" => "B"
- | #"5" => "A"
- | #"6" => "9"
- | #"7" => "8"
- | #"8" => "7"
- | #"9" => "6"
- | #"A" => "5"
- | #"B" => "4"
- | #"C" => "3"
- | #"D" => "2"
- | #"E" => "1"
- | #"F" => "0"
- | #"a" => "5"
- | #"b" => "4"
- | #"c" => "3"
- | #"d" => "2"
- | #"e" => "1"
- | #"f" => "0"
- | _ => "")
- in
- finish (iis, #"F")
- end
- else finish (IntInf.format (ii, StringCvt.HEX), #"0")
- end
- val ii = IntX.toIntInf i
- val (lo, hi) =
- if MLton.isMLton
- then convert1 ii
- else convert2 ii
- in
- Vector.new2
- ((x86.Operand.immediate_const_word lo, x86.Size.LONG),
- (x86.Operand.immediate_const_word hi, x86.Size.LONG))
- end
- end
| Label l =>
Vector.new1 (x86.Operand.immediate_label l, x86MLton.pointerSize)
| Line =>
1.17 +7 -7 mlton/mlton/defunctorize/defunctorize.fun
Index: defunctorize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/defunctorize.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- defunctorize.fun 12 Apr 2004 17:53:04 -0000 1.16
+++ defunctorize.fun 1 May 2004 00:49:41 -0000 1.17
@@ -14,9 +14,10 @@
structure Prim = Prim
structure Record = Record
structure Ctype = Type
+ structure WordSize = WordSize
+ structure WordX = WordX
end
-structure IntX = Const.IntX
structure Field = Record.Field
local
@@ -55,7 +56,6 @@
open Xcases
type t = exp t
- val int = Int
val word = Word
fun con v =
Con (Vector.map
@@ -761,8 +761,8 @@
if Xtype.equals (ty, Xtype.bool)
then
(case c of
- Const.Int i =>
- if 0 = IntX.toInt i
+ Const.Word w =>
+ if WordX.isZero w
then Xexp.falsee ()
else Xexp.truee ()
| _ => Error.bug "strange boolean constant")
@@ -809,10 +809,10 @@
datatype z = datatype Prim.Name.t
in
if (case Prim.name prim of
- Char_toWord8 => true
- | String_toWord8Vector => true
- | Word8_toChar => true
+ String_toWord8Vector => true
| Word8Vector_toString => true
+ | Word_toWord (s1, s2, _) =>
+ WordSize.equals (s1, s2)
| _ => false)
then Vector.sub (args, 0)
else
1.2 +1 -1 mlton/mlton/elaborate/const-type.sig
Index: const-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/const-type.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- const-type.sig 9 Oct 2003 18:17:33 -0000 1.1
+++ const-type.sig 1 May 2004 00:49:45 -0000 1.2
@@ -1,6 +1,6 @@
signature CONST_TYPE =
sig
- datatype t = Bool | Int | Real | String | Word
+ datatype t = Bool | Real | String | Word
val toString: t -> string
end
1.101 +10 -7 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.100
retrieving revision 1.101
diff -u -r1.100 -r1.101
--- elaborate-core.fun 13 Apr 2004 03:36:40 -0000 1.100
+++ elaborate-core.fun 1 May 2004 00:49:45 -0000 1.101
@@ -70,7 +70,6 @@
structure Cexp = Exp
structure Ffi = Ffi
structure IntSize = IntSize
- structure IntX = IntX
structure Lambda = Lambda
structure Cpat = Pat
structure Prim = Prim
@@ -187,6 +186,9 @@
expandOpaque = false,
var = fn _ => NONE}
+val typeTycon =
+ Trace.trace ("typeTycon", Type.layout, Option.layout Tycon.layout) typeTycon
+
fun 'a elabConst (c: Aconst.t,
make: (unit -> Const.t) * Type.t -> 'a,
{false = f: 'a, true = t: 'a}): 'a =
@@ -238,10 +240,11 @@
if Tycon.equals (tycon, Tycon.intInf)
then Const.IntInf i
else
- choose (tycon, IntSize.all, Tycon.int, fn s =>
- Const.Int
- (IntX.make (i, s)
- handle Overflow => (error ty; IntX.zero s))))
+ choose (tycon, WordSize.all, Tycon.word, fn s =>
+ Const.Word
+ (if WordSize.isInRange (s, i, {signed = true})
+ then WordX.fromIntInf (i, s)
+ else (error ty; WordX.zero s))))
end
| Aconst.Real r =>
let
@@ -263,7 +266,7 @@
(ty, fn tycon =>
choose (tycon, WordSize.all, Tycon.word, fn s =>
Const.Word
- (if w <= WordSize.max s
+ (if WordSize.isInRange (s, w, {signed = false})
then WordX.fromIntInf (w, s)
else (error ty
; WordX.zero s))))
@@ -2089,7 +2092,7 @@
if Tycon.equals (c, Tycon.bool)
then ConstType.Bool
else if Tycon.isIntX c
- then ConstType.Int
+ then ConstType.Word
else if Tycon.isRealX c
then ConstType.Real
else if Tycon.isWordX c
1.26 +1 -2 mlton/mlton/elaborate/elaborate.fun
Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- elaborate.fun 18 Mar 2004 03:22:25 -0000 1.25
+++ elaborate.fun 1 May 2004 00:49:46 -0000 1.26
@@ -42,11 +42,10 @@
structure ConstType =
struct
- datatype t = Bool | Int | Real | String | Word
+ datatype t = Bool | Real | String | Word
val toString =
fn Bool => "Bool"
- | Int => "Int"
| Real => "Real"
| String => "String"
| Word => "Word"
1.39 +35 -15 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- type-env.fun 13 Apr 2004 03:36:42 -0000 1.38
+++ type-env.fun 1 May 2004 00:49:46 -0000 1.39
@@ -1217,12 +1217,28 @@
val word8 = word WordSize.byte
- val synonyms =
- List.map
+ local
+ val {get: Tycon.t -> (t * Tycon.t) option, set, ...} =
+ Property.getSetOnce (Tycon.plist, Property.initConst NONE)
+ in
+ fun setSynonym (c, c') = set (c, SOME (con (c, Vector.new0 ()), c'))
+ val synonym = get
+ end
+
+ val () =
+ List.foreach
([(Tycon.char, Tycon.word WordSize.byte),
(Tycon.preThread, Tycon.thread)],
- fn (c, c') => (c, c', con (c, Vector.new0 ())))
+ setSynonym)
+
+ val () =
+ List.foreach
+ (IntSize.all, fn s =>
+ setSynonym (Tycon.int s,
+ Tycon.word (WordSize.fromBits (IntSize.bits s))))
+ val defaultInt = con (Tycon.int IntSize.default, Vector.new0 ())
+
fun 'a simpleHom {con: t * Tycon.t * 'a vector -> 'a,
expandOpaque: bool,
record: t * (Field.t * 'a) vector -> 'a,
@@ -1255,6 +1271,19 @@
(spine, fields, fields, fn (f, ac) =>
(f, unit) :: ac))
fun recursive _ = Error.bug "Type.hom recursive"
+ val con =
+ if not replaceSynonyms
+ then con
+ else
+ fn (t, c, ts) =>
+ let
+ val (t, c) =
+ case synonym c of
+ NONE => (t, c)
+ | SOME (t, c) => (t, c)
+ in
+ con (t, c, ts)
+ end
fun default (t, tycon) =
fn t' =>
let
@@ -1263,18 +1292,9 @@
in
con (t, tycon, Vector.new0 ())
end
- val int = default (int IntSize.default, Tycon.defaultInt)
- val real = default (real RealSize.default, Tycon.defaultReal)
- val word = default (word WordSize.default, Tycon.defaultWord)
- val con =
- if not replaceSynonyms
- then con
- else
- fn (t, c, ts) =>
- case List.peek (synonyms, fn (c', _, _) =>
- Tycon.equals (c, c')) of
- NONE => con (t, c, ts)
- | SOME (_, c, t) => con (t, c, Vector.new0 ())
+ val int = default (defaultInt, Tycon.defaultInt)
+ val real = default (defaultReal, Tycon.defaultReal)
+ val word = default (defaultWord, Tycon.defaultWord)
in
makeHom {con = con,
expandOpaque = expandOpaque,
1.21 +1 -1 mlton/mlton/elaborate/type-env.sig
Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- type-env.sig 12 Apr 2004 22:01:36 -0000 1.20
+++ type-env.sig 1 May 2004 00:49:46 -0000 1.21
@@ -55,7 +55,7 @@
val unresolvedWord: unit -> t
val var: Tyvar.t -> t
end
- sharing type Type.intSize = IntSize.t
+(* sharing type Type.intSize = IntSize.t *)
sharing type Type.realSize = RealSize.t
sharing type Type.wordSize = WordSize.t
sharing type Type.tycon = Tycon.t
1.30 +11 -5 mlton/mlton/main/compile.fun
Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- compile.fun 4 Apr 2004 06:50:21 -0000 1.29
+++ compile.fun 1 May 2004 00:49:47 -0000 1.30
@@ -45,7 +45,7 @@
in
structure Const = Const
structure Ffi = Ffi
- structure IntX = IntX
+ structure WordX = WordX
end
structure TypeEnv = TypeEnv (Atoms)
structure CoreML = CoreML (open Atoms
@@ -292,7 +292,7 @@
val lookupConstant =
let
- val zero = Const.int (IntX.make (0, IntSize.default))
+ val zero = Const.word (WordX.fromIntInf (0, WordSize.default))
val f =
Promise.lazy
(fn () =>
@@ -506,8 +506,8 @@
val _ =
let
fun get (s: string): Bytes.t =
- case lookupConstant (s, ConstType.Int) of
- Const.Int i => Bytes.fromInt (IntX.toInt i)
+ case lookupConstant (s, ConstType.Word) of
+ Const.Word w => Bytes.fromInt (WordX.toInt w)
| _ => Error.bug "GC_state offset must be an int"
in
Runtime.GCField.setOffsets
@@ -580,12 +580,18 @@
Layouts Ssa.Program.layouts)
else ()
end
+ val codegenImplementsPrim =
+ if !Control.Native.native
+ then x86Codegen.implementsPrim
+ else CCodegen.implementsPrim
val machine =
Control.pass
{name = "backend",
suffix = "machine",
style = Control.No,
- thunk = fn () => Backend.toMachine ssa,
+ thunk = fn () => (Backend.toMachine
+ (ssa,
+ {codegenImplementsPrim = codegenImplementsPrim})),
display = Control.Layouts Machine.Program.layouts}
val _ =
let
1.5 +5 -11 mlton/mlton/main/lookup-constant.fun
Index: lookup-constant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/lookup-constant.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- lookup-constant.fun 5 Mar 2004 03:50:55 -0000 1.4
+++ lookup-constant.fun 1 May 2004 00:49:47 -0000 1.5
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -12,11 +12,9 @@
local
open Const
in
- structure IntX = IntX
structure RealX = RealX
structure WordX = WordX
end
-structure IntSize = IntX.IntSize
structure RealSize = RealX.RealSize
structure WordSize = WordX.WordSize
@@ -84,7 +82,7 @@
List.map (gcFields, fn s =>
{name = s,
value = concat ["offsetof (struct GC_state, ", s, ")"],
- ty = ConstType.Int})
+ ty = ConstType.Word})
fun build (constants, out) =
let
@@ -109,7 +107,6 @@
val (format, value) =
case ty of
Bool => ("%s", concat [value, "? \"true\" : \"false\""])
- | Int => ("%d", value)
| Real => ("%.20f", value)
| String => ("%s", concat ["\"", escape value, "\""])
| Word => ("%u", value)
@@ -152,17 +149,14 @@
(table, String.hash name,
fn {name = name', ...} => name = name',
fn () => Error.bug (concat ["constant not found: ", name]))
- fun int i = Const.int (IntX.make (i, IntSize.default))
in
case ty of
Bool =>
(case Bool.fromString value of
NONE => Error.bug "strange Bool constant"
- | SOME b => int (if b then 1 else 0))
- | Int =>
- (case IntInf.fromString value of
- NONE => Error.bug "strange Int constant"
- | SOME i => int i)
+ | SOME b =>
+ Const.Word (WordX.fromIntInf
+ (if b then 1 else 0, WordSize.default)))
| Real =>
(case RealX.make (value, RealSize.default) of
NONE => Error.bug "strange Real constant"
1.160 +1 -0 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.159
retrieving revision 1.160
diff -u -r1.159 -r1.160
--- main.sml 7 Nov 2003 23:02:33 -0000 1.159
+++ main.sml 1 May 2004 00:49:47 -0000 1.160
@@ -6,4 +6,5 @@
in
debug := Out Out.error
; flagged ()
+ ; on []
end
1.11 +13 -32 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.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- match-compile.fun 4 Apr 2004 06:50:21 -0000 1.10
+++ match-compile.fun 1 May 2004 00:49:47 -0000 1.11
@@ -142,18 +142,13 @@
(get const, finish (Const.layout const,
Vector.fromList infos))))))
in
- val directCases =
- make (List.remove (IntSize.all, fn s =>
- IntSize.equals (s, IntSize.I (Bits.fromInt 64))),
- IntSize.cardinality, Type.int, Cases.int,
- fn Const.Int i => i
- | _ => Error.bug "caseInt type error")
- @ make (List.remove (WordSize.all, fn s =>
- WordSize.equals
- (s, WordSize.fromBits (Bits.fromInt 64))),
- WordSize.cardinality, Type.word, Cases.word,
- fn Const.Word w => w
- | _ => Error.bug "caseWord type error")
+ val directCases =
+ make (List.remove (WordSize.all, fn s =>
+ WordSize.equals
+ (s, WordSize.fromBits (Bits.fromInt 64))),
+ WordSize.cardinality, Type.word, Cases.word,
+ fn Const.Word w => w
+ | _ => Error.bug "caseWord type error")
end
(* unhandledConst cs returns a constant (of the appropriate type) not in cs. *)
@@ -187,25 +182,7 @@
datatype z = datatype Const.t
in
case c of
- Int i =>
- let
- val s = IntX.size i
- val min = IntX.toIntInf (IntX.min s)
- fun extract c =
- case c of
- Int i => IntX.toIntInf i
- | _ => Error.bug "expected Int"
- in
- search {<= = op <=,
- equals = op =,
- extract = extract,
- isMin = fn i => i = min,
- make = fn i => Const.int (IntX.make (i, s)),
- next = fn i => i + 1,
- prev = fn i => i - 1}
-
- end
- | IntInf _ =>
+ IntInf _ =>
let
fun extract c =
case c of
@@ -678,7 +655,11 @@
val matchCompile =
Trace.trace
("matchCompile",
- fn {cases, ...} => Vector.layout (NestedPat.layout o #1) cases,
+ fn {caseType, cases, test, testType, ...} =>
+ Layout.record [("caseType", Type.layout caseType),
+ ("cases", Vector.layout (NestedPat.layout o #1) cases),
+ ("test", Var.layout test),
+ ("testType", Type.layout testType)],
Exp.layout o #1)
matchCompile
1.6 +0 -2 mlton/mlton/match-compile/match-compile.sig
Index: match-compile.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/match-compile/match-compile.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- match-compile.sig 28 Apr 2004 03:17:06 -0000 1.5
+++ match-compile.sig 1 May 2004 00:49:47 -0000 1.6
@@ -17,7 +17,6 @@
val deTuple: t -> t vector
val equals: t * t -> bool
- val int: IntSize.t -> t
val layout: t -> Layout.t
val unit: t
val word: WordSize.t -> t
@@ -31,7 +30,6 @@
targs: Type.t vector,
arg: (Var.t * Type.t) option,
rhs: exp} vector -> t
- val int: IntSize.t * (IntX.t * exp) vector -> t
val word: WordSize.t * (WordX.t * exp) vector -> t
end
structure Exp:
1.24 +2 -3 mlton/mlton/ssa/analyze.fun
Index: analyze.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- analyze.fun 20 Feb 2004 02:11:15 -0000 1.23
+++ analyze.fun 1 May 2004 00:49:47 -0000 1.24
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -14,7 +14,7 @@
fun 'a analyze
{coerce, conApp, const,
- filter, filterInt, filterWord,
+ filter, filterWord,
fromType, layout, primApp,
program = Program.T {main, globals, functions, ...},
select, tuple, useFromTypeOnBinds} =
@@ -140,7 +140,6 @@
Con cases =>
Vector.foreach (cases, fn (c, j) =>
filter (test, c, labelValues j))
- | Int (s, cs) => doit (s, cs, filterInt)
| Word (s, cs) => doit (s, cs, filterWord)
val _ = Option.app (default, ensureNullary)
in ()
1.13 +0 -1 mlton/mlton/ssa/analyze.sig
Index: analyze.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.sig,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- analyze.sig 12 Apr 2004 17:53:05 -0000 1.12
+++ analyze.sig 1 May 2004 00:49:47 -0000 1.13
@@ -23,7 +23,6 @@
con: Con.t} -> 'a,
const: Const.t -> 'a,
filter: 'a * Con.t * 'a vector -> unit,
- filterInt: 'a * IntSize.t -> unit,
filterWord: 'a * WordSize.t -> unit,
fromType: Type.t -> 'a,
layout: 'a -> Layout.t,
1.25 +1 -3 mlton/mlton/ssa/common-subexp.fun
Index: common-subexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/common-subexp.fun,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- common-subexp.fun 18 Feb 2004 04:24:10 -0000 1.24
+++ common-subexp.fun 1 May 2004 00:49:47 -0000 1.25
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -206,9 +206,7 @@
Array_array => knownLength (arg ())
| Array_length => length ()
| Array_toVector => conv ()
- | String_toWord8Vector => conv ()
| Vector_length => length ()
- | Word8Vector_toString => conv ()
| _ => if Prim.isFunctional prim
then doit ()
else keep ()
1.19 +13 -12 mlton/mlton/ssa/constant-propagation.fun
Index: constant-propagation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/constant-propagation.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- constant-propagation.fun 18 Feb 2004 04:24:10 -0000 1.18
+++ constant-propagation.fun 1 May 2004 00:49:47 -0000 1.19
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -384,7 +384,7 @@
in new (Const c', Type.ofConst c)
end
- val zero = IntSize.memoize (fn s => const (S.Const.int (IntX.zero s)))
+ val zero = WordSize.memoize (fn s => const (S.Const.word (WordX.zero s)))
fun constToEltLength (c, err) =
let
@@ -402,8 +402,8 @@
else const' (Const.unknown (), Type.word8)
end
val n =
- const (Sconst.Int (IntX.make
- (IntInf.fromInt n, IntSize.default)))
+ const (Sconst.Word (WordX.fromIntInf (IntInf.fromInt n,
+ WordSize.default)))
in
{elt = x, length = n}
end
@@ -480,13 +480,13 @@
(case Type.dest t of
Type.Array t => Array {birth = arrayBirth (),
elt = loop t,
- length = loop Type.defaultInt}
+ length = loop Type.defaultWord}
| 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.defaultInt}
+ length = loop Type.defaultWord}
| Type.Weak t => Weak (loop t)
| _ => Const (const ()),
t)
@@ -622,12 +622,14 @@
else
let
fun error () =
- Error.bug ("strange coerce:" ^
- " from: " ^ (Layout.toString (Value.layout from)) ^
- " to: " ^ (Layout.toString (Value.layout to)))
+ Error.bug
+ (concat ["strange coerce: from: ",
+ Layout.toString (Value.layout from),
+ " to: ", Layout.toString (Value.layout to)])
in
case (value from, value to) of
- (Const from, Const to) => Const.coerce {from = from, to = to}
+ (Const from, Const to) =>
+ Const.coerce {from = from, to = to}
| (Datatype from, Datatype to) =>
coerceData {from = from, to = to}
| (Ref {birth, arg}, Ref {birth = b', arg = a'}) =>
@@ -754,7 +756,7 @@
case Prim.name prim of
Array_array => array (arg 0, bear ())
| Array_array0Const =>
- array (zero IntSize.default, Birth.here ())
+ array (zero WordSize.default, Birth.here ())
| Array_length => arrayLength (arg 0)
| Array_sub => dearray (arg 0)
| Array_toVector => vectorFromArray (arg 0)
@@ -815,7 +817,6 @@
conApp = conApp,
const = Value.const,
filter = filter,
- filterInt = filterIgnore,
filterWord = filterIgnore,
fromType = Value.fromType,
layout = Value.layout,
1.18 +2 -6 mlton/mlton/ssa/direct-exp.fun
Index: direct-exp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- direct-exp.fun 12 Apr 2004 17:53:05 -0000 1.17
+++ direct-exp.fun 1 May 2004 00:49:47 -0000 1.18
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -63,7 +63,6 @@
Con of {con: Con.t,
args: (Var.t * Type.t) vector,
body: t} vector
- | Int of IntSize.t * (IntX.t * t) vector
| Word of WordSize.t * (WordX.t * t) vector
val arith = Arith
@@ -80,6 +79,7 @@
val raisee = Raise
val select = Select
val seq = Seq
+val word = Const o Const.word
fun tuple (r as {exps, ...}) =
if 1 = Vector.length exps
@@ -111,8 +111,6 @@
val falsee = make Con.falsee
end
-val int = const o Const.int
-
fun eq (e1, e2, ty) =
primApp {prim = Prim.eq,
targs = Vector.new1 ty,
@@ -157,7 +155,6 @@
(seq [Con.layout con,
Vector.layout (Var.layout o #1) args],
body))
- | Int (_, v) => simple (v, IntX.layout)
| Word (_, v) => simple (v, WordX.layout)
end,
case default of
@@ -433,7 +430,6 @@
(v, fn {con, args, body} =>
(con,
newLabel (args, body, h, k))))
- | Int (s, v) => Cases.Int (s, doit v)
| Word (s, v) => Cases.Word (s, doit v)
end}})
end
1.15 +2 -3 mlton/mlton/ssa/direct-exp.sig
Index: direct-exp.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.sig,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- direct-exp.sig 12 Apr 2004 17:53:05 -0000 1.14
+++ direct-exp.sig 1 May 2004 00:49:47 -0000 1.15
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -24,7 +24,6 @@
Con of {con: Con.t,
args: (Var.t * Type.t) vector,
body: t} vector
- | Int of IntSize.t * (IntX.t * t) vector
| Word of WordSize.t * (WordX.t * t) vector
val arith: {prim: Type.t Prim.t,
@@ -56,7 +55,6 @@
ty: Type.t,
catch: Var.t * Type.t,
handler: t} -> t
- val int: IntX.t -> t
val layout: t -> Layout.t
val lett: {decs: {var: Var.t, exp: t} list,
body: t} -> t
@@ -78,5 +76,6 @@
val truee: t
val tuple: {exps: t vector, ty: Type.t} -> t
val var: Var.t * Type.t -> t
+ val word: WordX.t -> t
end
end
1.21 +11 -12 mlton/mlton/ssa/poly-equal.fun
Index: poly-equal.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/poly-equal.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- poly-equal.fun 18 Mar 2004 03:22:25 -0000 1.20
+++ poly-equal.fun 1 May 2004 00:49:47 -0000 1.21
@@ -43,10 +43,10 @@
open DirectExp
fun add (e1: t, e2: t): t =
- primApp {prim = Prim.intAdd IntSize.default,
+ primApp {prim = Prim.wordAdd WordSize.default,
targs = Vector.new0 (),
args = Vector.new2 (e1, e2),
- ty = Type.defaultInt}
+ ty = Type.defaultWord}
fun conjoin (e1: t, e2: t): t =
casee {test = e1,
@@ -201,16 +201,16 @@
Dexp.primApp {prim = Prim.vectorLength,
targs = Vector.new1 ty,
args = Vector.new1 x,
- ty = Type.defaultInt}
+ ty = Type.defaultWord}
in
Dexp.disjoin
(Dexp.eq (Dexp.var v1, Dexp.var v2, vty),
Dexp.conjoin
- (Dexp.eq (length dv1, length dv2, Type.defaultInt),
+ (Dexp.eq (length dv1, length dv2, Type.defaultWord),
Dexp.call
{func = loop,
args = (Vector.new4
- (Dexp.int (IntX.zero IntSize.default),
+ (Dexp.word (WordX.zero WordSize.default),
length dv1, dv1, dv2)),
ty = Type.bool}))
end
@@ -226,8 +226,8 @@
start = start}
end
local
- val i = (Var.newNoname (), Type.defaultInt)
- val len = (Var.newNoname (), Type.defaultInt)
+ val i = (Var.newNoname (), Type.defaultWord)
+ val len = (Var.newNoname (), Type.defaultWord)
val v1 = (Var.newNoname (), vty)
val v2 = (Var.newNoname (), vty)
val args = Vector.new4 (i, len, v1, v2)
@@ -245,11 +245,11 @@
val args =
Vector.new4
(Dexp.add
- (di, Dexp.int (IntX.one IntSize.default)),
+ (di, Dexp.word (WordX.one WordSize.default)),
dlen, dv1, dv2)
in
Dexp.disjoin
- (Dexp.eq (di, dlen, Type.defaultInt),
+ (Dexp.eq (di, dlen, Type.defaultWord),
Dexp.conjoin
(equalExp (sub (dv1, di), sub (dv2, di), ty),
Dexp.call {args = args,
@@ -292,7 +292,6 @@
else Dexp.call {func = equalFunc tycon,
args = Vector.new2 (dx1, dx2),
ty = Type.bool}
- | Type.Int s => prim (Prim.intEqual s, Vector.new0 ())
| Type.IntInf => if hasConstArg ()
then eq ()
else prim (Prim.intInfEqual, Vector.new0 ())
@@ -332,11 +331,11 @@
case exp of
Const c =>
(case c of
- Const.Int _ => const ()
- | Const.IntInf i =>
+ Const.IntInf i =>
if Const.SmallIntInf.isSmall i
then const ()
else ()
+ | Const.Word _ => const ()
| _ => ())
| ConApp {args, ...} =>
if Vector.isEmpty args then const () else ()
1.20 +56 -48 mlton/mlton/ssa/redundant-tests.fun
Index: redundant-tests.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/redundant-tests.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- redundant-tests.fun 12 Apr 2004 17:53:05 -0000 1.19
+++ redundant-tests.fun 1 May 2004 00:49:47 -0000 1.20
@@ -14,14 +14,18 @@
structure Rel =
struct
- datatype t = EQ | LT | LE | NE
+ datatype t =
+ EQ
+ | LT of {signed: bool}
+ | LE of {signed: bool}
+ | NE
val equals: t * t -> bool = op =
val toString =
fn EQ => "="
- | LT => "<"
- | LE => "<="
+ | LT _ => "<"
+ | LE _ => "<="
| NE => "<>"
val layout = Layout.str o toString
@@ -67,14 +71,15 @@
val rel =
case rel of
EQ => NE
- | LT => LE
- | LE => LT
+ | LT s => LE s
+ | LE s => LT s
| NE => EQ
in
T {rel = rel, lhs = rhs, rhs = lhs}
end
datatype result = False | True | Unknown
+
fun determine (facts: t list, f: t): result =
if List.contains (facts, f, equals)
then True
@@ -120,17 +125,12 @@
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
- Int_equal _ => doit EQ
- | Int_ge _ => doit' LE
- | Int_gt _ => doit' LT
- | Int_le _ => doit LE
- | Int_lt _ => doit LT
- | MLton_eq => doit EQ
+ MLton_eq => doit EQ
| Word_equal _ => doit EQ
- | Word_ge _ => doit' LE
- | Word_gt _ => doit' LT
- | Word_le _ => doit LE
- | Word_lt _ => doit LT
+ | Word_ge (_, sg) => doit' (LE sg)
+ | Word_gt (_, sg) => doit' (LT sg)
+ | Word_le (_, sg) => doit (LE sg)
+ | Word_lt (_, sg) => doit (LT sg)
| _ => None
end
fun setConst (x, c) = setVarInfo (x, Const c)
@@ -158,15 +158,15 @@
val statements = ref []
in
val one =
- IntSize.memoize
+ WordSize.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,
+ Statement.T {exp = Exp.Const (Const.word (WordX.one s)),
+ ty = Type.word s,
var = SOME one})
in
one
@@ -373,7 +373,7 @@
let
fun simplify (prim: Type.t Prim.t,
x: Var.t,
- s: IntSize.t) =
+ s: WordSize.t) =
let
val res = Var.newNoname ()
in
@@ -384,56 +384,62 @@
{exp = PrimApp {args = Vector.new2 (x, one s),
prim = prim,
targs = Vector.new0 ()},
- ty = Type.int s,
+ ty = Type.word s,
var = SOME res})],
Goto {args = Vector.new1 res,
dst = success})
end
- fun add1 (x: Var.t, s: IntSize.t) =
+ fun add1 (x: Var.t, s: WordSize.t, sg) =
if isFact (label, fn Fact.T {lhs, rel, rhs} =>
case (lhs, rel, rhs) of
- (Oper.Var x', Rel.LT, _) =>
+ (Oper.Var x', Rel.LT sg', _) =>
Var.equals (x, x')
- | (Oper.Var x', Rel.LE, Oper.Const c) =>
+ andalso sg = sg'
+ | (Oper.Var x', Rel.LE sg',
+ Oper.Const c) =>
Var.equals (x, x')
+ andalso sg = sg'
andalso
(case c of
- Const.Int i =>
- IntX.<
- (i, IntX.max (IntX.size i))
+ Const.Word w =>
+ WordX.lt
+ (w, WordX.max (s, sg), sg)
| _ => Error.bug "strange fact")
| _ => false)
- then simplify (Prim.intAdd s, x, s)
+ then simplify (Prim.wordAdd s, x, s)
else noChange
- fun sub1 (x: Var.t, s: IntSize.t) =
+ fun sub1 (x: Var.t, s: WordSize.t, sg) =
if isFact (label, fn Fact.T {lhs, rel, rhs} =>
case (lhs, rel, rhs) of
- (_, Rel.LT, Oper.Var x') =>
+ (_, Rel.LT sg', Oper.Var x') =>
Var.equals (x, x')
- | (Oper.Const c, Rel.LE, Oper.Var x') =>
+ andalso sg = sg'
+ | (Oper.Const c, Rel.LE sg',
+ Oper.Var x') =>
Var.equals (x, x')
+ andalso sg = sg'
andalso
(case c of
- Const.Int i =>
- IntX.>
- (i, IntX.min (IntX.size i))
+ Const.Word w =>
+ WordX.gt
+ (w, WordX.min (s, sg), sg)
| _ => Error.bug "strange fact")
| _ => false)
- then simplify (Prim.intSub s, x, s)
+ then simplify (Prim.wordSub s, x, s)
else noChange
- fun add (c: Const.t, x: Var.t, s: IntSize.t) =
+ fun add (c: Const.t, x: Var.t, (s, sg as {signed})) =
case c of
- Const.Int i =>
- if IntX.isOne i
- then add1 (x, s)
- else if IntX.isNegOne i
- then sub1 (x, s)
+ Const.Word i =>
+ if WordX.isOne i
+ then add1 (x, s, sg)
+ else if signed andalso WordX.isNegOne i
+ then sub1 (x, s, sg)
else noChange
| _ => Error.bug "add of strange const"
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
- Int_addCheck s =>
+ Word_addCheck s =>
let
val x1 = Vector.sub (args, 0)
val x2 = Vector.sub (args, 1)
@@ -444,7 +450,7 @@
Const c => add (c, x1, s)
| _ => noChange)
end
- | Int_subCheck s =>
+ | Word_subCheck (s, sg as {signed}) =>
let
val x1 = Vector.sub (args, 0)
val x2 = Vector.sub (args, 1)
@@ -452,12 +458,14 @@
case varInfo x2 of
Const c =>
(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
+ Const.Word w =>
+ if WordX.isOne w
+ then sub1 (x1, s, sg)
+ else
+ if (signed
+ andalso WordX.isNegOne w)
+ then add1 (x1, s, sg)
+ else noChange
| _ =>
Error.bug "sub of strage const")
| _ => noChange
1.27 +3 -4 mlton/mlton/ssa/remove-unused.fun
Index: remove-unused.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/remove-unused.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- remove-unused.fun 15 Mar 2004 02:06:26 -0000 1.26
+++ remove-unused.fun 1 May 2004 00:49:47 -0000 1.27
@@ -468,12 +468,11 @@
| Case {test, cases, default}
=> let
val _ = visitVar test
- fun doit l = (Vector.foreach (l, fn (_, l) => visitLabel l);
- Option.app (default, visitLabel))
in
case cases of
- Cases.Int (_, cs) => doit cs
- | Cases.Word (_, cs) => doit cs
+ Cases.Word (_, cs) =>
+ (Vector.foreach (cs, visitLabel o #2)
+ ; Option.app (default, visitLabel))
| Cases.Con cases
=> if Vector.length cases = 0
then Option.app (default, visitLabel)
1.40 +18 -54 mlton/mlton/ssa/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- shrink.fun 12 Apr 2004 17:53:05 -0000 1.39
+++ shrink.fun 1 May 2004 00:49:47 -0000 1.40
@@ -918,50 +918,18 @@
| SOME l => tryToEliminate (labelMeaning l))
else
let
- val m = labelMeaning (Cases.hd cases)
- local
- open LabelMeaning
- in
- fun usesFormal (T {aux, blockIndex = i, ...}): bool =
- case aux of
- Block =>
- 0 < Vector.length (Block.args
- (Vector.sub (blocks, i)))
- | Bug => false
- | Goto {args, ...} => Positions.usesFormal args
- | Raise {args, ...} => Positions.usesFormal args
- | Return {args, ...} => Positions.usesFormal args
- | _ => true
- fun rr ({args = a, canMove = c},
- {args = a', canMove = c'}) =
- Positions.equals (a, a')
- andalso List.equals (c, c', Statement.equals)
- fun equals (m: t, m': t): bool =
- case (aux m, aux m') of
- (Block, Block) => blockIndex m = blockIndex m'
- | (Bug, Bug) => true
- | (Goto {dst, args},
- Goto {dst = dst', args = args'}) =>
- equals (dst, dst')
- andalso Positions.equals (args, args')
- | (Raise z, Raise z') => rr (z, z')
- | (Return z, Return z') => rr (z, z')
- | _ => false
- end
- fun isOk (l: Label.t): bool =
- let
- val m' = labelMeaning l
- in
- not (usesFormal m') andalso equals (m, m')
- end
+ val l = Cases.hd cases
+ fun isOk (l': Label.t): bool = Label.equals (l, l')
in
- if Cases.forall (cases, isOk)
+ if 0 = Vector.length (Block.args
+ (Vector.sub (blocks, labelIndex l)))
+ andalso Cases.forall (cases, isOk)
andalso (case default of
NONE => true
| SOME l => isOk l)
then
(* All cases the same -- eliminate the case. *)
- tryToEliminate m
+ tryToEliminate (labelMeaning l)
else
let
fun findCase (cases, is, args) =
@@ -989,27 +957,23 @@
then doit (j, args)
else loop (k + 1)
end
- in loop 0
+ in
+ loop 0
end
in
case (VarInfo.value test, cases) of
(SOME (Value.Const c), _) =>
- let
- fun doit (l, z, eq) =
- findCase (l, fn z' => eq (z, z'),
- Vector.new0 ())
- in
- 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
+ (case (cases, c) of
+ (Cases.Word (_, cs), Const.Word w) =>
+ findCase (cs,
+ fn w' => WordX.equals (w, w'),
+ Vector.new0 ())
+ | _ =>
+ Error.bug "strange constant for cases")
| (SOME (Value.Con {con, args}), Cases.Con cases) =>
- findCase (cases, fn c =>
- Con.equals (con, c), args)
+ findCase (cases,
+ fn c => Con.equals (con, c),
+ args)
| _ => cantSimplify ()
(*
| (NONE, _) => cantSimplify ()
1.70 +8 -21 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -r1.69 -r1.70
--- ssa-tree.fun 12 Apr 2004 17:53:06 -0000 1.69
+++ ssa-tree.fun 1 May 2004 00:49:47 -0000 1.70
@@ -26,7 +26,6 @@
datatype dest =
Array of t
| Datatype of Tycon.t
- | Int of IntSize.t
| IntInf
| Real of RealSize.t
| Ref of t
@@ -52,7 +51,6 @@
val tycons =
[(Tycon.array, unary Array)]
- @ Vector.toListMap (Tycon.ints, fn (t, s) => (t, nullary (Int s)))
@ [(Tycon.intInf, nullary IntInf)]
@ Vector.toListMap (Tycon.reals, fn (t, s) => (t, nullary (Real s)))
@ [(Tycon.reff, unary Ref),
@@ -84,7 +82,6 @@
case dest t of
Array t => seq [layout t, str " array"]
| Datatype t => Tycon.layout t
- | Int s => str (concat ["int", IntSize.toString s])
| IntInf => str "IntInf.int"
| Real s => str (concat ["real", RealSize.toString s])
| Ref t => seq [layout t, str " ref"]
@@ -104,7 +101,6 @@
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 =
@@ -116,7 +112,6 @@
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
@@ -132,7 +127,6 @@
in
case c of
Con cs => doit cs
- | Int (_, cs) => doit cs
| Word (_, cs) => doit cs
end
@@ -142,7 +136,6 @@
in
case c of
Con cs => doit cs
- | Int (_, cs) => doit cs
| Word (_, cs) => doit cs
end
@@ -152,7 +145,6 @@
in
case c of
Con l => doit l
- | Int (_, l) => doit l
| Word (_, l) => doit l
end
@@ -162,7 +154,6 @@
in
case c of
Con l => Con (doit l)
- | Int (s, l) => Int (s, doit l)
| Word (s, l) => Word (s, doit l)
end
@@ -172,7 +163,6 @@
in
case c of
Con l => doit l
- | Int (_, l) => doit l
| Word (_, l) => doit l
end
@@ -595,13 +585,12 @@
fun iff (test: Var.t, {truee, falsee}) =
let
- val s = IntSize.I (Bits.fromInt 32)
+ val s = WordSize.fromBits (Bits.fromInt 32)
in
- Case
- {cases = Cases.Int (s, Vector.new2 ((IntX.zero s, falsee),
- (IntX.one s, truee))),
- default = NONE,
- test = test}
+ Case {cases = Cases.Word (s, Vector.new2 ((WordX.zero s, falsee),
+ (WordX.one s, truee))),
+ default = NONE,
+ test = test}
end
fun foreachFuncLabelVar (t, func, label: Label.t -> unit, var) =
@@ -685,20 +674,20 @@
val cases =
case cases of
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
| SOME j =>
cases @ [seq [str "_ => ", Label.layout j]]
- in align [seq [str "case ", Var.layout test, str " of"],
+ in
+ align [seq [str "case ", Var.layout test, str " of"],
indent (alignPrefix (cases, "| "), 2)]
end
val layout =
fn Arith {prim, args, overflow, success, ...} =>
- seq [Label.layout success,
+ seq [Label.layout success, str " ",
tuple [Prim.layoutApp (prim, args, Var.layout)],
str " Overflow => ",
Label.layout overflow, str " ()"]
@@ -1117,8 +1106,6 @@
val _ =
case cases of
Cases.Con v => doit (v, Con.toString)
- | Cases.Int (_, v) =>
- doit (v, IntX.toString)
| Cases.Word (_, v) =>
doit (v, WordX.toString)
val _ =
1.57 +0 -2 mlton/mlton/ssa/ssa-tree.sig
Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- ssa-tree.sig 12 Apr 2004 17:53:07 -0000 1.56
+++ ssa-tree.sig 1 May 2004 00:49:47 -0000 1.57
@@ -60,7 +60,6 @@
datatype dest =
Array of t
| Datatype of Tycon.t
- | Int of IntSize.t
| IntInf
| Real of RealSize.t
| Ref of t
@@ -120,7 +119,6 @@
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
1.33 +0 -3 mlton/mlton/ssa/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- type-check.fun 13 Apr 2004 03:36:42 -0000 1.32
+++ type-check.fun 1 May 2004 00:49:47 -0000 1.33
@@ -128,7 +128,6 @@
in
case cases of
Cases.Con cs => doitCon cs
- | Cases.Int (_, cs) => doit (cs, IntX.equals, IntX.hash)
| Cases.Word (_, cs) =>
doit (cs, WordX.equals, Word.fromIntInf o WordX.toIntInf)
end
@@ -400,8 +399,6 @@
conApp = conApp,
const = Type.ofConst,
filter = filter,
- 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,
1.24 +9 -12 mlton/mlton/ssa/useless.fun
Index: useless.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/useless.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- useless.fun 18 Mar 2004 10:31:48 -0000 1.23
+++ useless.fun 1 May 2004 00:49:47 -0000 1.24
@@ -246,7 +246,7 @@
case Type.dest t of
Type.Array t =>
let val elt as (_, e) = slot t
- val length = loop Type.defaultInt
+ val length = loop Type.defaultWord
in Exists.addHandler
(e, fn () => Useful.makeUseful (deground length))
; Array {useful = useful (),
@@ -256,7 +256,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.defaultInt,
+ | Type.Vector t => Vector {length = loop Type.defaultWord,
elt = slot t}
| Type.Weak t => Weak {arg = slot t,
useful = useful ()}
@@ -565,7 +565,6 @@
conApp = conApp,
const = Value.const,
filter = filter,
- filterInt = filterGround o #1,
filterWord = filterGround o #1,
fromType = Value.fromType,
layout = Value.layout,
@@ -926,13 +925,6 @@
end
| Case {test, cases, default} =>
let
- (* The test may be useless if there are no cases or default,
- * thus we must eliminate the case.
- *)
- fun doit v =
- case (Vector.length v, default) of
- (0, NONE) => ([], Bug)
- | _ => ([], t)
datatype z = datatype Cases.t
in
case cases of
@@ -962,8 +954,13 @@
cases = Cases.Con cases,
default = default})
end)
- | Int (_, cs) => doit cs
- | Word (_, cs) => doit cs
+ | Word (_, cs) =>
+ (* The test may be useless if there are no cases or
+ * default, thus we must eliminate the case.
+ *)
+ case (Vector.length cs, default) of
+ (0, NONE) => ([], Bug)
+ | _ => ([], t)
end
| Goto {dst, args} =>
([], Goto {dst = dst, args = keepUseful (args, label dst)})
1.17 +4 -4 mlton/mlton/xml/monomorphise.fun
Index: monomorphise.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/monomorphise.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- monomorphise.fun 12 Apr 2004 17:53:08 -0000 1.16
+++ monomorphise.fun 1 May 2004 00:49:48 -0000 1.17
@@ -278,15 +278,15 @@
SprimExp.App {func = monoVarExp func, arg = monoVarExp arg}
| XprimExp.Case {test, cases, default} =>
let
- fun doit cases =
- Vector.map (cases, fn (c, e) => (c, monoExp e))
val cases =
case cases of
Xcases.Con cases =>
Scases.Con (Vector.map (cases, fn (pat, exp) =>
(monoPat pat, monoExp exp)))
- | Xcases.Int (s, l) => Scases.Int (s, doit l)
- | Xcases.Word (s, l) => Scases.Word (s, doit l)
+ | Xcases.Word (s, v) =>
+ Scases.Word
+ (s, Vector.map (v, fn (c, e) => (c, monoExp e)))
+
in
SprimExp.Case
{test = monoVarExp test,
1.15 +6 -6 mlton/mlton/xml/polyvariance.fun
Index: polyvariance.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/polyvariance.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- polyvariance.fun 20 Feb 2004 02:11:15 -0000 1.14
+++ polyvariance.fun 1 May 2004 00:49:48 -0000 1.15
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -313,9 +313,6 @@
| Case {test, cases, default} =>
let
datatype z = datatype Cases.t
- fun doit cases =
- Vector.map (cases, fn (z, e) =>
- (z, loopExp e))
val cases =
case cases of
Con cases =>
@@ -323,8 +320,11 @@
(Vector.map
(cases, fn (p, e) =>
(bindPat p, loopExp e)))
- | Int (s, v) => Int (s, doit v)
- | Word (s, v) => Word (s, doit v)
+ | Word (s, v) =>
+ Word
+ (s, (Vector.map
+ (v, fn (z, e) =>
+ (z, loopExp e))))
in
Case {test = loopVar test,
cases = cases,
1.6 +5 -13 mlton/mlton/xml/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/shrink.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- shrink.fun 18 Mar 2004 03:22:26 -0000 1.5
+++ shrink.fun 1 May 2004 00:49:48 -0000 1.6
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -397,18 +397,10 @@
| _ => false)
end
| (_, SOME (Value.Const c)) =>
- let
- 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
+ (case (cases, c) of
+ (Cases.Word (_, l), Const.Word w) =>
+ match (l, fn w' => WordX.equals (w, w'))
+ | _ => Error.bug "strange case")
| (_, NONE) => normal varExp
| _ => Error.bug "shrinkMonoVal"
end
1.11 +4 -4 mlton/mlton/xml/simplify-types.fun
Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify-types.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- simplify-types.fun 12 Apr 2004 17:53:08 -0000 1.10
+++ simplify-types.fun 1 May 2004 00:49:48 -0000 1.11
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -246,14 +246,14 @@
func = fixVarExp func}
| I.PrimExp.Case {cases, default, test} =>
let
- fun doit v = Vector.map (v, fn (c, e) => (c, fixExp e))
val cases =
case cases of
I.Cases.Con v =>
O.Cases.Con (Vector.map (v, fn (p, e) =>
(fixPat p, fixExp e)))
- | I.Cases.Int (s, v) => O.Cases.Int (s, doit v)
- | I.Cases.Word (s, v) => O.Cases.Word (s, doit v)
+ | I.Cases.Word (s, v) =>
+ O.Cases.Word
+ (s, Vector.map (v, fn (c, e) => (c, fixExp e)))
in
O.PrimExp.Case {cases = cases,
default = Option.map (default, fn (e, r) =>
1.18 +3 -5 mlton/mlton/xml/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/type-check.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- type-check.fun 12 Apr 2004 17:53:08 -0000 1.17
+++ type-check.fun 1 May 2004 00:49:48 -0000 1.18
@@ -186,9 +186,6 @@
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
in
case cases of
@@ -196,8 +193,9 @@
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)
+ | Word (s, cs) =>
+ finish (Vector.new1 (Type.word s),
+ Vector.map (cs, fn (_, e) => checkExp e))
end
| ConApp {con, targs, arg} =>
let
1.21 +1 -6 mlton/mlton/xml/xml-tree.fun
Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- xml-tree.fun 12 Apr 2004 17:53:08 -0000 1.20
+++ xml-tree.fun 1 May 2004 00:49:48 -0000 1.21
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -76,7 +76,6 @@
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 layout (cs, layout) =
@@ -89,7 +88,6 @@
in
case cs of
Con v => doit (v, Pat.layout)
- | Int (_, v) => doit (v, IntX.layout)
| Word (_, v) => doit (v, WordX.layout)
end
@@ -99,7 +97,6 @@
in
case c of
Con l => doit l
- | Int (_, l) => doit l
| Word (_, l) => doit l
end
@@ -109,7 +106,6 @@
in
case c of
Con l => Con (doit l)
- | Int (s, l) => Int (s, doit l)
| Word (s, l) => Word (s, doit l)
end
@@ -121,7 +117,6 @@
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
1.15 +1 -2 mlton/mlton/xml/xml-tree.sig
Index: xml-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.sig,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- xml-tree.sig 12 Apr 2004 17:53:08 -0000 1.14
+++ xml-tree.sig 1 May 2004 00:49:48 -0000 1.15
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -44,7 +44,6 @@
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
1.81 +0 -8 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.80
retrieving revision 1.81
diff -u -r1.80 -r1.81
--- Makefile 29 Apr 2004 02:58:58 -0000 1.80
+++ Makefile 1 May 2004 00:49:48 -0000 1.81
@@ -37,13 +37,9 @@
basis/GC/setSummary.o \
basis/IEEEReal.o \
basis/IntInf.o \
- basis/Int/Int64.o \
basis/Int/Word8Array.o \
basis/Int/Word8Vector.o \
basis/Int/Word64.o \
- basis/Int/addOverflow.o \
- basis/Int/mulOverflow.o \
- basis/Int/negOverflow.o \
basis/Int/quot.o \
basis/Int/subOverflow.o \
basis/Itimer/set.o \
@@ -203,13 +199,9 @@
basis/GC/setSummary-gdb.o \
basis/IEEEReal-gdb.o \
basis/IntInf-gdb.o \
- basis/Int/Int64-gdb.o \
basis/Int/Word8Array-gdb.o \
basis/Int/Word8Vector-gdb.o \
basis/Int/Word64-gdb.o \
- basis/Int/addOverflow-gdb.o \
- basis/Int/mulOverflow-gdb.o \
- basis/Int/negOverflow-gdb.o \
basis/Int/quot-gdb.o \
basis/Int/subOverflow-gdb.o \
basis/Itimer/set-gdb.o \
1.6 +10 -0 mlton/runtime/types.h
Index: types.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/types.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- types.h 4 Apr 2004 18:21:43 -0000 1.5
+++ types.h 1 May 2004 00:49:48 -0000 1.6
@@ -19,6 +19,16 @@
typedef unsigned long Word32;
typedef unsigned long long Word64;
+typedef Int8 WordS8;
+typedef Int16 WordS16;
+typedef Int32 WordS32;
+typedef Int64 WordS64;
+
+typedef Word8 WordU8;
+typedef Word16 WordU16;
+typedef Word32 WordU32;
+typedef Word64 WordU64;
+
typedef Int32 Int;
typedef Real64 Real;
typedef Word8 Char;
1.2 +53 -41 mlton/runtime/basis/Int/Word64.c
Index: Word64.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Int/Word64.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Word64.c 11 Sep 2003 00:51:08 -0000 1.1
+++ Word64.c 1 May 2004 00:49:49 -0000 1.2
@@ -11,40 +11,44 @@
t f##_to##t (f x) { \
return (t)x; \
}
-coerce(Int32,Word64)
-coerce(Word8,Word64)
-coerce(Word16,Word64)
-coerce(Word32,Word64)
-coerce(Word64,Int32)
-coerce(Word64,Word8)
-coerce(Word64,Word16)
-coerce(Word64,Word32)
+coerce (WordS16, Word64)
+coerce (WordS32, Word64)
+coerce (WordS8, Word64)
+coerce (WordU16, Word64)
+coerce (WordU32, Word64)
+coerce (WordU64, Word16)
+coerce (WordU64, Word32)
+coerce (WordU64, Word8)
+coerce (WordU8, Word64)
#undef coerce
-#define coerceX(size, t) \
- t Word##size##_to##t##X (Word##size w) { \
- return (t)(Int##size)w; \
- }
-coerceX(8,Word64)
-coerceX(16,Word64)
-coerceX(32,Word64)
-coerceX(64,Int32)
-#undef coerceX
-
#define binary(name, op) \
Word64 Word64_##name (Word64 w1, Word64 w2) { \
return w1 op w2; \
}
binary (add, +)
binary (andb, &)
-binary (div, /)
-binary (mod, %)
-binary (mul, *)
binary (orb, |)
binary (sub, -)
binary (xorb, ^)
#undef binary
+#define binary(kind, name, op) \
+ Word64 Word##kind##64_##name (Word##kind##64 w1, Word##kind##64 w2) { \
+ Word##kind##64 res = w1 op w2; \
+ if (DEBUG) \
+ fprintf (stderr, "%lld = " #name " (%lld, %lld)\n", \
+ res, w1, w2); \
+ return res; \
+ }
+binary (S, mul, *)
+binary (U, mul, *)
+binary (S, quot, /)
+binary (U, quot, /)
+binary (S, rem, %)
+binary (U, rem, %)
+#undef binary
+
#define unary(name, op) \
Word64 Word64_##name (Word64 w) { \
return op w; \
@@ -53,28 +57,36 @@
unary (notb, ~)
#undef unary
-#define compare(name, op) \
- Bool Word64_##name (Word64 w1, Word64 w2) { \
- return w1 op w2; \
- }
-compare (equal, ==)
-compare (ge, >=)
-compare (gt, >)
-compare (le, <=)
-compare (lt, <)
-#undef binary
+Bool Word64_equal (Word64 w1, Word64 w2) {
+ Bool res = w1 == w2;
+ if (DEBUG)
+ fprintf (stderr, "%s = %llu == %llu\n",
+ res ? "true" : "false", w1, w2);
+ return res;
+}
-#define shift(name, op) \
- Word64 Word64_##name (Word64 w1, Word w2) { \
- return w1 op w2; \
+#define compare(s, name, op) \
+ Bool Word##s##64_##name (Word##s##64 w1, Word##s##64 w2) { \
+ return w1 op w2; \
}
-shift (lshift, <<)
-shift (rshift, >>)
-#undef binary
-
-Word64 Word64_arshift (Word64 w, Word s) {
- return (Int64)w >> s;
-}
+compare (S, ge, >=)
+compare (U, ge, >=)
+compare (S, gt, >)
+compare (U, gt, >)
+compare (S, le, <=)
+compare (U, le, <=)
+compare (S, lt, <)
+compare (U, lt, <)
+#undef compare
+
+#define shift(size,name, op) \
+ Word64 Word##size##_##name (Word##size w1, Word w2) { \
+ return w1 op w2; \
+ }
+shift (64, lshift, <<)
+shift (S64, rshift, >>)
+shift (U64, rshift, >>)
+#undef shift
Word64 Word64_rol (Word64 w1, Word w2) {
return (w1 >> (64 - w2)) | (w1 << w2);
1.8 +20 -5 mlton/runtime/basis/Int/quot.c
Index: quot.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Int/quot.c,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- quot.c 29 Nov 2003 09:33:25 -0000 1.7
+++ quot.c 1 May 2004 00:49:49 -0000 1.8
@@ -2,6 +2,10 @@
#include "mlton-basis.h"
+enum {
+ DEBUG = 0,
+};
+
/*
* We have to be very careful implementing Int_quot and Int_rem using / and %
* because C allows
@@ -27,16 +31,27 @@
*/
#if ! (defined (__i386__) || defined (__sparc__))
-#error check that C / correctly implements quot from the basis library
+#error check that C {/,%} correctly implement {quot,rem} from the basis library
#endif
+#define WordS8_format "%c"
+#define WordS16_format "%d"
+#define WordS32_format "%d"
+#define WordS64_format "%lld"
+
#define binary(size, name, op) \
- Int##size Int##size##_##name (Int##size i, Int##size j) { \
- return i op j; \
+ WordS##size WordS##size##_##name (WordS##size i, WordS##size j) { \
+ WordS##size res = i op j; \
+ if (DEBUG) \
+ fprintf (stderr, WordS##size##_format \
+ " = " WordS##size##_format " " \
+ #op " " WordS##size##_format "\n", \
+ res, i, j); \
+ return res; \
}
-#define both(size) \
- binary(size, quot, /) \
+#define both(size) \
+ binary(size, quot, /) \
binary(size, rem, %)
both(8)