[MLton] cvs commit: fixed Int64 and C codegen bugs
sweeks@mlton.org
sweeks@mlton.org
Sat, 29 Nov 2003 01:33:25 -0800
sweeks 03/11/29 01:33:25
Modified: basis-library/misc primitive.sml
include c-chunk.h
mlton/backend ssa-to-rssa.fun
mlton/codegen/c-codegen c-codegen.fun
runtime Makefile
runtime/basis/Int Int64.c quot.c
Removed: runtime/basis/Int rem.c
Log:
MAIL fixed Int64 and C codegen bugs
Fixed bugs with C codegen and Int64. There were a couple of problems.
First, some primitives that were implemented by C routines were
treated as prims (not FFIs) by the C codegen. As a consequence, there
was no C function prototype output in the chunk. This fails when the
size of the return value is not an int, which is the case for many
Int64 primitives. I fixed this problem by going through and changing
most _imports to _prims and then adding code to SsaToRssa that
carefully creates either the prim or the FFI call depending on which
codegen is used and the size of the operand. That approach seems
better than what we had, because making things _prim (instead of
_import) in the basis library means that the SSA optimizer gets a
chance to improve things. Also, the knowledge about what codegen
implements what primitive is all collected in SsaToRssa.
I made the C codegen use primitives for more Int64 ops.
There was a bug in how Int64 constants were printed. To be safe, I
added a trailing "ll" to all of them.
Revision Changes Path
1.87 +12 -14 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.86
retrieving revision 1.87
diff -u -r1.86 -r1.87
--- primitive.sml 10 Nov 2003 18:38:34 -0000 1.86
+++ primitive.sml 29 Nov 2003 09:33:24 -0000 1.87
@@ -111,7 +111,7 @@
val leave = _import "Debug_leave": string -> unit;
end
end
-
+
structure Primitive =
struct
val detectOverflow = _build_const "MLton_detectOverflow": bool;
@@ -415,15 +415,13 @@
structure Int = Int32
structure Int64 =
struct
- infix 7 *?
-
type int = Int64.int
val precision' : Int.int = 64
val maxInt' : int = 0x7FFFFFFFFFFFFFFF
val minInt' : int = ~0x8000000000000000
- val op *? = _import "Int64_mul": int * int -> int;
+ val *? = _prim "Int64_mul": int * int -> int;
val +? = _prim "Int64_add": int * int -> int;
val + =
if detectOverflow
@@ -434,23 +432,23 @@
if detectOverflow
then _prim "Int64_subCheck": int * int -> int;
else -?
- val op < = _import "Int64_lt": int * int -> bool;
- val op <= = _import "Int64_le": int * int -> bool;
- val op > = _import "Int64_gt": int * int -> bool;
- val op >= = _import "Int64_ge": int * int -> bool;
+ 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 quot = _import "Int64_quot": int * int -> int;
val rem = _import "Int64_rem": int * int -> int;
- val geu = _import "Int64_geu": int * int -> bool;
- val gtu = _import "Int64_gtu": int * int -> bool;
+ val geu = _import "Int64_geu": int * int -> bool;
+ val gtu = _import "Int64_gtu": int * int -> bool;
val ~? = _prim "Int64_neg": int -> int;
val ~ =
if detectOverflow
then _prim "Int64_negCheck": int -> int;
else ~?
- val fromInt = _import "Int32_toInt64": Int.int -> int;
- val fromWord = _import "Word32_toInt64": word -> int;
- val toInt = _import "Int64_toInt32": int -> Int.int;
- val toWord = _import "Int64_toWord32": int -> word;
+ 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 * = fn _ => raise Fail "Int64.* unimplemented"
end
1.16 +8 -8 mlton/include/c-chunk.h
Index: c-chunk.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-chunk.h,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- c-chunk.h 21 Oct 2003 19:00:41 -0000 1.15
+++ c-chunk.h 29 Nov 2003 09:33:24 -0000 1.16
@@ -392,8 +392,8 @@
#define intAllBinary(name, op) \
intBinary(name,op,8) \
intBinary(name,op,16) \
- intBinary(name,op,32)
-// intBinary(name,op,64)
+ intBinary(name,op,32) \
+ intBinary(name,op,64)
intAllBinary (add, +)
intAllBinary (mul, *)
intAllBinary (sub, -)
@@ -408,8 +408,8 @@
#define intAllBinaryCompare(name, op) \
intBinaryCompare(name,op,8) \
intBinaryCompare(name,op,16) \
- intBinaryCompare(name,op,32)
-// intBinaryCompare(name,op,64)
+ intBinaryCompare(name,op,32) \
+ intBinaryCompare(name,op,64)
intAllBinaryCompare (equal, ==)
intAllBinaryCompare (ge, >=)
intAllBinaryCompare (gt, >)
@@ -603,10 +603,10 @@
return (t)x; \
}
//coerce (Int64, Int64)
-//coerce (Int64, Int32)
+coerce (Int64, Int32)
//coerce (Int64, Int16)
//coerce (Int64, Int8)
-//coerce (Int32, Int64)
+coerce (Int32, Int64)
coerce (Int32, Int32)
coerce (Int32, Int16)
coerce (Int32, Int8)
@@ -626,7 +626,7 @@
coerce (Int16, Real32)
coerce (Int8, Real64)
coerce (Int8, Real32)
-//coerce (Int64, Word32)
+coerce (Int64, Word32)
//coerce (Int64, Word16)
//coerce (Int64, Word8)
coerce (Int32, Word32)
@@ -650,7 +650,7 @@
coerce (Real64, Real32)
coerce (Real32, Real64)
coerce (Real32, Real32)
-//coerce (Word32, Int64)
+coerce (Word32, Int64)
coerce (Word32, Int32)
coerce (Word32, Int16)
coerce (Word32, Int8)
1.50 +117 -0 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.49
retrieving revision 1.50
diff -u -r1.49 -r1.50
--- ssa-to-rssa.fun 9 Oct 2003 18:17:32 -0000 1.49
+++ ssa-to-rssa.fun 29 Nov 2003 09:33:24 -0000 1.50
@@ -129,6 +129,57 @@
val int64Equal = make "Int64_equal"
end
+ local
+ fun make name =
+ IntSize.memoize
+ (fn s =>
+ vanilla {args = Vector.new2 (CType.Int s, CType.Int s),
+ name = concat ["Int", IntSize.toString s, "_", name],
+ return = SOME CType.bool})
+ in
+ val intGe = make "ge"
+ val intGt = make "gt"
+ val intLe = make "le"
+ val intLt = make "lt"
+ end
+
+ local
+ val int = ("Int", CType.Int, IntSize.memoize, IntSize.toString)
+ val word = ("Word", CType.Word, WordSize.memoize, WordSize.toString)
+ fun make ((fromName, fromType, fromMemo, fromString),
+ (toName, toType, toMemo, toString)) =
+ let
+ val f =
+ fromMemo
+ (fn s1 =>
+ toMemo
+ (fn s2 =>
+ vanilla {args = Vector.new1 (fromType s1),
+ name = concat [fromName, fromString s1,
+ "_to", toName, toString s2],
+ return = SOME (toType s2)}))
+ in
+ fn (s1, s2) => f s1 s2
+ end
+ in
+ val intToInt = make (int, int)
+ val intToWord = make (int, word)
+ val wordToInt = make (word, int)
+ end
+
+ local
+ fun make name =
+ IntSize.memoize
+ (fn s =>
+ vanilla {args = Vector.new2 (CType.Int s, CType.Int s),
+ name = concat ["Int", IntSize.toString s, "_", name],
+ return = SOME (CType.Int s)})
+ in
+ val intMul = make "mul"
+ val intQuot = make "quot"
+ val intRem = make "rem"
+ end
+
val word64Equal = vanilla {args = Vector.new2 (Word64, Word64),
name = "Word64_equal",
return = SOME CType.defaultInt}
@@ -1174,6 +1225,60 @@
if s = IntSize.I64 andalso !Control.Native.native
then simpleCCall CFunction.int64Equal
else normal ()
+ | Int_ge s =>
+ if s = IntSize.I64 andalso !Control.Native.native
+ then simpleCCall (CFunction.intGe s)
+ else normal ()
+ | Int_gt s =>
+ if s = IntSize.I64 andalso !Control.Native.native
+ then simpleCCall (CFunction.intGt s)
+ else normal ()
+ | Int_le s =>
+ if s = IntSize.I64 andalso !Control.Native.native
+ then simpleCCall (CFunction.intLe s)
+ else normal ()
+ | Int_lt s =>
+ if s = IntSize.I64 andalso !Control.Native.native
+ then simpleCCall (CFunction.intLt s)
+ else normal ()
+ | Int_mul s =>
+ if s = IntSize.I64 andalso !Control.Native.native
+ then simpleCCall (CFunction.intMul s)
+ else normal ()
+ | Int_quot s =>
+ if s = IntSize.I64
+ orelse not (!Control.Native.native)
+ then simpleCCall (CFunction.intQuot s)
+ else normal ()
+ | Int_rem s =>
+ if s = IntSize.I64
+ orelse not (!Control.Native.native)
+ then simpleCCall (CFunction.intRem s)
+ else normal ()
+ | Int_toInt (s1, s2) =>
+ let
+ datatype z = datatype IntSize.t
+ in
+ if (case (s1, s2) of
+ (I32, I64) => true
+ | (I64, I32) => true
+ | _ => false)
+ andalso !Control.Native.native
+ then simpleCCall (CFunction.intToInt (s1, s2))
+ else normal ()
+ end
+ | Int_toWord (s1, s2) =>
+ let
+ datatype z = datatype IntSize.t
+ datatype z = datatype WordSize.t
+ in
+ if (case (s1, s2) of
+ (I64, W32) => true
+ | _ => false)
+ andalso !Control.Native.native
+ then simpleCCall (CFunction.intToWord (s1, s2))
+ else normal ()
+ end
| IntInf_add => simpleCCall CFunction.intInfAdd
| IntInf_andb => simpleCCall CFunction.intInfAndb
| IntInf_arshift =>
@@ -1371,6 +1476,18 @@
if s = WordSize.W64
then simpleCCall CFunction.word64Equal
else normal ()
+ | Word_toInt (s1, s2) =>
+ let
+ datatype z = datatype IntSize.t
+ datatype z = datatype WordSize.t
+ in
+ if (case (s1, s2) of
+ (W64, I32) => true
+ | _ => false)
+ andalso !Control.Native.native
+ then simpleCCall (CFunction.wordToInt (s1, s2))
+ else normal ()
+ end
| Word_toIntInf => cast ()
| WordVector_toIntInf => cast ()
| Word8Array_subWord => sub Type.defaultWord
1.70 +2 -2 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.69
retrieving revision 1.70
diff -u -r1.69 -r1.70
--- c-codegen.fun 9 Oct 2003 18:17:32 -0000 1.69
+++ c-codegen.fun 29 Nov 2003 09:33:24 -0000 1.70
@@ -93,7 +93,7 @@
I8 => simple "8"
| I16 => simple "16"
| I32 => tricky ("0x80000000")
- | I64 => concat ["(Int64)", tricky "0x8000000000000000"]
+ | I64 => concat [tricky "0x8000000000000000", "ll"]
end
end
@@ -129,7 +129,7 @@
W8 => simple "8"
| W16 => simple "16"
| W32 => concat ["0x", toString w]
- | W64 => simple "64"
+ | W64 => concat ["0x", toString w, "llu"]
end
end
1.75 +0 -2 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.74
retrieving revision 1.75
diff -u -r1.74 -r1.75
--- Makefile 11 Sep 2003 00:51:08 -0000 1.74
+++ Makefile 29 Nov 2003 09:33:24 -0000 1.75
@@ -39,7 +39,6 @@
basis/Int/mulOverflow.o \
basis/Int/negOverflow.o \
basis/Int/quot.o \
- basis/Int/rem.o \
basis/Int/subOverflow.o \
basis/Itimer/set.o \
basis/MLton/allocTooLarge.o \
@@ -207,7 +206,6 @@
basis/Int/mulOverflow-gdb.o \
basis/Int/negOverflow-gdb.o \
basis/Int/quot-gdb.o \
- basis/Int/rem-gdb.o \
basis/Int/subOverflow-gdb.o \
basis/Itimer/set-gdb.o \
basis/MLton/allocTooLarge-gdb.o \
1.3 +0 -7 mlton/runtime/basis/Int/Int64.c
Index: Int64.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Int/Int64.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- Int64.c 31 Jul 2003 20:32:59 -0000 1.2
+++ Int64.c 29 Nov 2003 09:33:25 -0000 1.3
@@ -4,9 +4,6 @@
DEBUG = FALSE,
};
-#define Int64_max (Int64)0x7FFFFFFFFFFFFFFF
-#define Int64_min (Int64)0x8000000000000000
-
#define binary(name, op) \
Int64 Int64_##name (Int64 i, Int64 j) { \
if (DEBUG) \
@@ -14,11 +11,7 @@
i op j, i, j); \
return i op j; \
}
-binary(add, +)
binary(mul, *)
-binary(sub, -)
-binary(quot, /)
-binary(rem, %)
#undef binary
#define compare(name, op) \
1.7 +11 -10 mlton/runtime/basis/Int/quot.c
Index: quot.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Int/quot.c,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- quot.c 25 Jun 2003 21:22:53 -0000 1.6
+++ quot.c 29 Nov 2003 09:33:25 -0000 1.7
@@ -30,15 +30,16 @@
#error check that C / correctly implements quot from the basis library
#endif
-Int8 Int8_quot (Int8 n, Int8 d) {
- return n / d;
-}
+#define binary(size, name, op) \
+ Int##size Int##size##_##name (Int##size i, Int##size j) { \
+ return i op j; \
+ }
-Int16 Int16_quot (Int16 n, Int16 d) {
- return n / d;
-}
-
-Int32 Int32_quot (Int32 n, Int32 d) {
- return n / d;
-}
+#define both(size) \
+ binary(size, quot, /) \
+ binary(size, rem, %)
+both(8)
+both(16)
+both(32)
+both(64)