[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)