[MLton] cvs commit: C types now distinguish between signed and unsigned words

Stephen Weeks sweeks@mlton.org
Mon, 6 Sep 2004 17:46:22 -0700


sweeks      04/09/06 17:46:20

  Modified:    doc/user-guide ffi.tex
               mlton/atoms atoms.fun atoms.sig c-function.fun
                        c-function.sig c-type.fun c-type.sig
               mlton/backend limit-check.fun profile.fun rep-type.fun
                        rep-type.sig ssa-to-rssa.fun
               mlton/codegen/c-codegen c-codegen.fun
               mlton/codegen/x86-codegen x86-mlton-basic.fun x86.fun
               mlton/elaborate elaborate-core.fun
               runtime  platform.h
               runtime/basis IntInf.c
  Log:
  MAIL C types now distinguish between signed and unsigned words
  
  This distinction is necessary because on some platforms the calling
  convention for signeds and unsigneds is different.  This can happen
  when a small word (e.g. 8 bit) is represented in a larger word
  (e.g. 32 bit), in which case the signed version will be passed sign
  extended and the unsigned version will be passed zero extended.
  
  One unfortunate side effect of this change is that the type
  information for a C function (CFunction.t) is now duplicated, because
  we need the CType information to generate the prototype, while we need
  different type information for type checking the ILs.  It's not clear
  if this duplication is worth the gain in type checking, especially
  since the C prototype can lie anyways.  But, I've left it in for now.
  Of course, another fix would be to make the IL type information
  sufficiently precise that it subsumes the CType information.  But
  that's a bit more pervasive of a change than I'm willing to stomach
  right now, plus I think it makes arbitrary distinctions between signed
  and unsigneds.
  
  A quick check reveals that generated C code now has correct prototypes
  for the Word_{quot,rem} functions.
  
    Int8 WordS8_quot (Int8 x1, Int8 x0);
    Int8 WordS8_rem (Int8 x1, Int8 x0);
    Int32 WordS32_quot (Int32 x1, Int32 x0);
    Int32 WordS32_rem (Int32 x1, Int32 x0);
  
  Filip, let us know if the fixed-integer regression now works without
  needing any explicit sign extensions, or if this checkin has caused
  any other problems.

Revision  Changes    Path
1.25      +1 -1      mlton/doc/user-guide/ffi.tex

Index: ffi.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/ffi.tex,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- ffi.tex	11 Aug 2004 01:57:05 -0000	1.24
+++ ffi.tex	7 Sep 2004 00:46:18 -0000	1.25
@@ -132,7 +132,7 @@
 \hline
 {\tt array} & {\tt Pointer} & {\tt char *} \\
 {\tt bool} & {\tt Int32} & {\tt long} \\
-{\tt char} & {\tt Word8} & {\tt unsigned char} \\
+{\tt char} & {\tt Int8} & {\tt char} \\
 {\tt Int8.int} & {\tt Int8} & {\tt char} \\
 {\tt Int16.int} & {\tt Int16} & {\tt short} \\
 {\tt Int32.int} & {\tt Int32} & {\tt long} \\



1.19      +2 -2      mlton/mlton/atoms/atoms.fun

Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- atoms.fun	1 May 2004 00:49:34 -0000	1.18
+++ atoms.fun	7 Sep 2004 00:46:18 -0000	1.19
@@ -21,7 +21,7 @@
 			       structure RealSize = RealSize
 			       structure WordSize = WordSize)
       structure Con = Con ()
-      structure CType = CType ()
+      structure CType = CType (structure WordSize = WordSize)
       structure RealX = RealX (structure RealSize = RealSize)
       structure WordX = WordX (structure WordSize = WordSize)
       structure Func =
@@ -36,7 +36,7 @@
 	 end
       structure Const = Const (structure RealX = RealX
 			       structure WordX = WordX)
-      structure CFunction = CFunction ()
+      structure CFunction = CFunction (structure CType = CType)
       structure Prim = Prim (structure CFunction = CFunction
 			     structure CType = CType
 			     structure Con = Con



1.19      +3 -2      mlton/mlton/atoms/atoms.sig

Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- atoms.sig	1 May 2004 00:49:34 -0000	1.18
+++ atoms.sig	7 Sep 2004 00:46:18 -0000	1.19
@@ -42,14 +42,15 @@
       structure WordX: WORD_X
 
       sharing CFunction = Ffi.CFunction = Prim.CFunction
-      sharing CType = Ffi.CType = Prim.CType 
+      sharing CType = CFunction.CType = Ffi.CType = Prim.CType 
       sharing Con = Prim.Con
       sharing Const = Prim.Const
       sharing IntSize = Tycon.IntSize
       sharing RealSize = Prim.RealSize = RealX.RealSize = Tycon.RealSize
       sharing RealX = Const.RealX
       sharing SourceInfo = ProfileExp.SourceInfo
-      sharing WordSize = Prim.WordSize = Tycon.WordSize = WordX.WordSize
+      sharing WordSize = CType.WordSize = Prim.WordSize = Tycon.WordSize
+	 = WordX.WordSize
       sharing WordX = Const.WordX
    end
 



1.8       +6 -3      mlton/mlton/atoms/c-function.fun

Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- c-function.fun	20 Aug 2004 16:34:44 -0000	1.7
+++ c-function.fun	7 Sep 2004 00:46:18 -0000	1.8
@@ -24,6 +24,7 @@
 		      maySwitchThreads: bool,
 		      modifiesFrontier: bool,
 		      name: string,
+		      prototype: CType.t vector * CType.t option,
 		      readsStackTop: bool,
 		      return: 'a,
 		      writesStackTop: bool}
@@ -63,8 +64,8 @@
 fun equals (f, f') = name f = name f'
 
 fun map (T {args, bytesNeeded, convention, ensuresBytesFree, mayGC,
-	    maySwitchThreads, modifiesFrontier, name, readsStackTop, return,
-	    writesStackTop},
+	    maySwitchThreads, modifiesFrontier, name, prototype, readsStackTop,
+	    return, writesStackTop},
 	 f) =
    T {args = Vector.map (args, f),
       bytesNeeded = bytesNeeded,
@@ -74,6 +75,7 @@
       maySwitchThreads = maySwitchThreads,
       modifiesFrontier = modifiesFrontier,
       name = name,
+      prototype = prototype,
       readsStackTop = readsStackTop,
       return = f return,
       writesStackTop = writesStackTop}
@@ -94,7 +96,7 @@
 		     andalso readsStackTop andalso writesStackTop)
 	    else true)
 
-fun vanilla {args, name, return} =
+fun vanilla {args, name, prototype, return} =
    T {args = args,
       bytesNeeded = NONE,
       convention = Convention.Cdecl,
@@ -103,6 +105,7 @@
       maySwitchThreads = false,
       modifiesFrontier = false,
       name = name,
+      prototype = prototype,
       readsStackTop = false,
       return = return,
       writesStackTop = false}



1.5       +3 -0      mlton/mlton/atoms/c-function.sig

Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- c-function.sig	20 Aug 2004 16:34:44 -0000	1.4
+++ c-function.sig	7 Sep 2004 00:46:18 -0000	1.5
@@ -9,6 +9,7 @@
    
 signature C_FUNCTION_STRUCTS = 
    sig
+      structure CType: C_TYPE
    end
 
 signature C_FUNCTION = 
@@ -38,6 +39,7 @@
 			     maySwitchThreads: bool,
 			     modifiesFrontier: bool,
 			     name: string,
+			     prototype: CType.t vector * CType.t option,
 			     readsStackTop: bool,
 			     return: 'a,
 			     writesStackTop: bool}
@@ -58,5 +60,6 @@
       val writesStackTop: 'a t -> bool
       val vanilla: {args: 'a vector,
 		    name: string,
+		    prototype: CType.t vector * CType.t option,
 		    return: 'a} -> 'a t
    end



1.6       +53 -7     mlton/mlton/atoms/c-type.fun

Index: c-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- c-type.fun	12 Apr 2004 17:52:48 -0000	1.5
+++ c-type.fun	7 Sep 2004 00:46:18 -0000	1.6
@@ -1,10 +1,21 @@
+(* 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 CType (S: C_TYPE_STRUCTS): C_TYPE = 
 struct
 
 open S
 
 datatype t =
-   Pointer
+   Int8
+ | Int16
+ | Int32
+ | Int64
+ | Pointer
  | Real32
  | Real64
  | Word8
@@ -12,11 +23,14 @@
  | Word32
  | Word64
 
-val all = [Pointer, Real32, Real64, Word8, Word16, Word32, Word64]
+val all = [Int8, Int16, Int32, Int64,
+	   Pointer,
+	   Real32, Real64,
+	   Word8, Word16, Word32, Word64]
 
 val bool = Word32
 
-val char = Word8
+val char = Int8
 
 val pointer = Pointer
 
@@ -31,12 +45,20 @@
       val pointer = f Pointer
       val real32 = f Real32
       val real64 = f Real64
+      val int8 = f Int8
+      val int16 = f Int16
+      val int32 = f Int32
+      val int64 = f Int64
       val word8 = f Word8
       val word16 = f Word16
       val word32 = f Word32
       val word64 = f Word64
    in
-      fn Pointer => pointer
+      fn Int8 => int8
+       | Int16 => int16
+       | Int32 => int32
+       | Int64 => int64
+       | Pointer => pointer
        | Real32 => real32
        | Real64 => real64
        | Word8 => word8
@@ -46,7 +68,11 @@
    end
 
 val toString =
-   fn Pointer => "Pointer"
+   fn Int8 => "Int8"
+    | Int16 => "Int16"
+    | Int32 => "Int32"
+    | Int64 => "Int64"
+    | Pointer => "Pointer"
     | Real32 => "Real32"
     | Real64 => "Real64"
     | Word8 => "Word8"
@@ -58,7 +84,11 @@
 
 fun size (t: t): Bytes.t =
    case t of
-      Pointer => Bytes.inPointer
+      Int8 => Bytes.fromInt 1
+    | Int16 => Bytes.fromInt 2
+    | Int32 => Bytes.fromInt 4
+    | Int64 => Bytes.fromInt 8
+    | Pointer => Bytes.inPointer
     | Real32 => Bytes.fromInt 4
     | Real64 => Bytes.fromInt 8
     | Word8 => Bytes.fromInt 1
@@ -68,7 +98,11 @@
 
 fun name t =
    case t of
-      Pointer => "P"
+      Int8 => "I8"
+    | Int16 => "I16"
+    | Int32 => "I32"
+    | Int64 => "I64"
+    | Pointer => "P"
     | Real32 => "R32"
     | Real64 => "R64"
     | Word8 => "W8"
@@ -78,5 +112,17 @@
 
 fun align (t: t, b: Bytes.t): Bytes.t =
    Bytes.align (b, {alignment = size t})
+
+fun word (s: WordSize.t, {signed: bool}): t =
+   case (signed, Bits.toInt (WordSize.bits s)) of
+      (false, 8) => Word8
+    | (true, 8) => Int8
+    | (false, 16) => Word16
+    | (true, 16) => Int16
+    | (false, 32) => Word32
+    | (true, 32) => Int32
+    | (false, 64) => Word64
+    | (true, 64) => Int64
+    | _ => Error.bug "CType.word"
 
 end



1.7       +8 -2      mlton/mlton/atoms/c-type.sig

Index: c-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- c-type.sig	28 Apr 2004 03:17:05 -0000	1.6
+++ c-type.sig	7 Sep 2004 00:46:19 -0000	1.7
@@ -7,6 +7,7 @@
 
 signature C_TYPE_STRUCTS = 
    sig
+      structure WordSize: WORD_SIZE
    end
 
 signature C_TYPE = 
@@ -14,7 +15,11 @@
       include C_TYPE_STRUCTS
 
       datatype t =
-	 Pointer
+	 Int8
+       | Int16
+       | Int32
+       | Int64
+       | Pointer
        | Real32
        | Real64
        | Word8
@@ -28,7 +33,7 @@
       val char: t
       val equals: t * t -> bool
       val memo: (t -> 'a) -> t -> 'a
-      (* name: R{32,64} W{8,16,32,64} *)
+      (* name: I{8,16,32,64} R{32,64} W{8,16,32,64} *)
       val name: t -> string
       val layout: t -> Layout.t
       val pointer: t
@@ -36,4 +41,5 @@
       val size: t -> Bytes.t
       val thread: t
       val toString: t -> string
+      val word: WordSize.t * {signed: bool} -> t
    end



1.55      +1 -0      mlton/mlton/backend/limit-check.fun

Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- limit-check.fun	20 Aug 2004 16:34:44 -0000	1.54
+++ limit-check.fun	7 Sep 2004 00:46:19 -0000	1.55
@@ -160,6 +160,7 @@
 				     maySwitchThreads = false,
 				     modifiesFrontier = false,
 				     name = "MLton_allocTooLarge",
+				     prototype = (Vector.new0 (), NONE),
 				     readsStackTop = false,
 				     return = Type.unit,
 				     writesStackTop = false}



1.42      +8 -4      mlton/mlton/backend/profile.fun

Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- profile.fun	20 Aug 2004 16:34:44 -0000	1.41
+++ profile.fun	7 Sep 2004 00:46:19 -0000	1.42
@@ -17,7 +17,7 @@
       end
 
       local
-	 fun make {args, name} =
+	 fun make {args, name, prototype} =
 	    T {args = args,
 	       bytesNeeded = NONE,
 	       convention = Convention.Cdecl,
@@ -26,19 +26,23 @@
 	       maySwitchThreads = false,
 	       modifiesFrontier = false,
 	       name = name,
+	       prototype = (prototype, NONE),
 	       readsStackTop = true,
 	       return = unit,
 	       writesStackTop = false}
       in
 	 val profileEnter =
 	    make {args = Vector.new1 gcState,
-		  name = "GC_profileEnter"}
+		  name = "GC_profileEnter",
+		  prototype = Vector.new1 CType.Pointer}
 	 val profileInc =
 	    make {args = Vector.new2 (gcState, Word32),
-		  name = "GC_profileInc"}
+		  name = "GC_profileInc",
+		  prototype = Vector.new2 (CType.Pointer, CType.Word32)}
 	 val profileLeave =
 	    make {args = Vector.new1 gcState,
-		  name = "GC_profileLeave"}
+		  name = "GC_profileLeave",
+		  prototype = Vector.new1 CType.Pointer}
       end
    end
 



1.12      +7 -9      mlton/mlton/backend/rep-type.fun

Index: rep-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rep-type.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- rep-type.fun	31 Aug 2004 04:56:31 -0000	1.11
+++ rep-type.fun	7 Sep 2004 00:46:19 -0000	1.12
@@ -150,15 +150,6 @@
 	    end
 	 fun w i = word (Bits.fromInt i)
       in
-	 val fromCType: CType.t -> t =
-	    fn C.Pointer => w 32
-	     | C.Real32 => real RealSize.R32
-	     | C.Real64 => real RealSize.R64
-	     | C.Word8 => w 8
-	     | C.Word16 => w 16
-	     | C.Word32 => w 32
-	     | C.Word64 => w 64
-
 	 val rec toCType: t -> CType.t =
 	    fn t =>
 	    if isPointer t
@@ -480,6 +471,7 @@
 	 
       val bug = vanilla {args = Vector.new1 string,
 			 name = "MLton_bug",
+			 prototype = (Vector.new1 CType.pointer, NONE),
 			 return = unit}
 
       local
@@ -503,6 +495,12 @@
 		   maySwitchThreads = b,
 		   modifiesFrontier = true,
 		   name = "GC_gc",
+		   prototype = let
+				  open CType
+			       in
+				  (Vector.new5 (Pointer, Word32, bool, Pointer, Word32),
+				   NONE)
+			       end,
 		   readsStackTop = true,
 		   return = unit,
 		   writesStackTop = true}



1.10      +0 -1      mlton/mlton/backend/rep-type.sig

Index: rep-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rep-type.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- rep-type.sig	12 Aug 2004 23:06:03 -0000	1.9
+++ rep-type.sig	7 Sep 2004 00:46:19 -0000	1.10
@@ -69,7 +69,6 @@
       val defaultWord: t
       val equals: t * t -> bool
       val exnStack: t
-      val fromCType: CType.t -> t
       val gcState: t
       val intInf: t
       val isCPointer: t -> bool



1.97      +155 -26   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.96
retrieving revision 1.97
diff -u -r1.96 -r1.97
--- ssa-to-rssa.fun	31 Aug 2004 04:56:36 -0000	1.96
+++ ssa-to-rssa.fun	7 Sep 2004 00:46:19 -0000	1.97
@@ -61,6 +61,11 @@
 	    maySwitchThreads = false,
 	    modifiesFrontier = true,
 	    name = "GC_copyCurrentThread",
+	    prototype = let
+			   open CType
+			in
+			   (Vector.new1 Pointer, NONE)
+			end,
 	    readsStackTop = true,
 	    return = unit,
 	    writesStackTop = true}
@@ -74,6 +79,11 @@
 	    maySwitchThreads = false,
 	    modifiesFrontier = true,
 	    name = "GC_copyThread",
+	    prototype = let
+			   open CType
+			in
+			   (Vector.new2 (Pointer, Pointer), SOME Pointer)
+			end,
 	    readsStackTop = true,
 	    return = Type.thread,
 	    writesStackTop = true}
@@ -87,6 +97,11 @@
 	    maySwitchThreads = false,
 	    modifiesFrontier = true,
 	    name = "MLton_exit",
+	    prototype = let
+			   open CType
+			in
+			   (Vector.new1 Word32, NONE)
+			end,
 	    readsStackTop = true,
 	    return = unit,
 	    writesStackTop = true}
@@ -100,6 +115,12 @@
 	    maySwitchThreads = false,
 	    modifiesFrontier = true,
 	    name = "GC_arrayAllocate",
+	    prototype = let
+			   open CType
+			in
+			   (Vector.new4 (Pointer, Word32, Word32, Word32),
+			    SOME Pointer)
+			end,
 	    readsStackTop = true,
 	    return = return,
 	    writesStackTop = true}
@@ -114,6 +135,11 @@
 	       maySwitchThreads = false,
 	       modifiesFrontier = true,
 	       name = name,
+	       prototype = let
+			      open CType
+			   in
+			      (Vector.new1 Pointer, NONE)
+			   end,
 	       readsStackTop = true,
 	       return = unit,
 	       writesStackTop = true}
@@ -131,6 +157,11 @@
 	    maySwitchThreads = true,
 	    modifiesFrontier = true,
 	    name = "Thread_returnToC",
+	    prototype = let
+			   open CType
+			in
+			   (Vector.new0 (), NONE)
+			end,
 	    readsStackTop = true,
 	    return = unit,
 	    writesStackTop = true}
@@ -144,6 +175,11 @@
 	    maySwitchThreads = true,
 	    modifiesFrontier = true,
 	    name = "Thread_switchTo",
+	    prototype = let
+			   open CType
+			in
+			   (Vector.new2 (Pointer, Word32), NONE)
+			end,
 	    readsStackTop = true,
 	    return = unit,
 	    writesStackTop = true}
@@ -151,11 +187,21 @@
       fun weakCanGet t =
 	 vanilla {args = Vector.new1 t,
 		  name = "GC_weakCanGet",
+		  prototype = let
+				 open CType
+			      in
+				 (Vector.new1 Pointer, SOME bool)
+			      end,
 		  return = Type.bool}
 	 
       fun weakGet {arg, return} =
 	 vanilla {args = Vector.new1 arg,
 		  name = "GC_weakGet",
+		  prototype = let
+				 open CType
+			      in
+				 (Vector.new1 Pointer, SOME Pointer)
+			      end,
 		  return = return}
 		  
       fun weakNew {arg, return} =
@@ -167,7 +213,12 @@
 	    maySwitchThreads = false,
 	    modifiesFrontier = true,
 	    name = "GC_weakNew",
-	    readsStackTop = true,
+	    prototype = let
+			   open CType
+			in
+			   (Vector.new3 (Pointer, Word32, Pointer), SOME Pointer)
+			end,
+            readsStackTop = true,
 	    return = return,
 	    writesStackTop = true}
 
@@ -180,6 +231,11 @@
 	    maySwitchThreads = false,
 	    modifiesFrontier = true,
 	    name = "GC_saveWorld",
+	    prototype = let
+			   open CType
+			in
+			   (Vector.new2 (Pointer, Word32), NONE)
+			end,
 	    readsStackTop = true,
 	    return = unit,
 	    writesStackTop = true}
@@ -187,11 +243,21 @@
       fun share t =
 	 vanilla {args = Vector.new1 t,
 		  name = "MLton_share",
+		  prototype = let
+				 open CType
+			      in
+				 (Vector.new1 Pointer, NONE)
+			      end,
 		  return = unit}
 
       fun size t =
 	 vanilla {args = Vector.new1 t,
 		  name = "MLton_size",
+		  prototype = let
+				 open CType
+			      in
+				 (Vector.new1 Pointer, SOME Word32)
+			      end,
 		  return = Word32}
    end
 
@@ -207,9 +273,13 @@
 	    val name = toString n
 	    val word = Type.word o WordSize.bits
 	    val vanilla = CFunction.vanilla
-	    fun coerce (t1, t2) =
+	    fun coerce (t1, t2, sg) =
 	       vanilla {args = Vector.new1 t1,
 			name = name,
+			prototype = (Vector.new1
+				     (CType.word
+				      (WordSize.fromBits (Type.width t1), sg)),
+				     SOME (Type.toCType t2)),
 			return = t2}
 	    fun intInfBinary () =
 	       CFunction.T {args = Vector.new3 (Type.intInf, Type.intInf,
@@ -221,6 +291,12 @@
 			    maySwitchThreads = false,
 			    modifiesFrontier = true,
 			    name = name,
+			    prototype = let
+					   open CType
+					in
+					   (Vector.new3 (Pointer, Pointer, Word32),
+					    SOME Pointer)
+					end,
 			    readsStackTop = false,
 			    return = Type.intInf,
 			    writesStackTop = false}
@@ -235,6 +311,12 @@
 			    maySwitchThreads = false,
 			    modifiesFrontier = true,
 			    name = name,
+			    prototype = let
+					   open CType
+					in
+					   (Vector.new3 (Pointer, Word32, Word32),
+					    SOME Pointer)
+					end,
 			    readsStackTop = false,
 			    return = Type.intInf,
 			    writesStackTop = false}
@@ -249,6 +331,12 @@
 			    maySwitchThreads = false,
 			    modifiesFrontier = true,
 			    name = name,
+			    prototype = let
+					   open CType
+					in
+					   (Vector.new3 (Pointer, Word32, Word32),
+					    SOME Pointer)
+					end,
 			    readsStackTop = false,
 			    return = Type.string,
 			    writesStackTop = false}
@@ -261,28 +349,56 @@
 			    maySwitchThreads = false,
 			    modifiesFrontier = true,
 			    name = name,
+			    prototype = let
+					   open CType
+					in
+					   (Vector.new2 (Pointer, Word32),
+					    SOME Pointer)
+					end,
 			    readsStackTop = false,
 			    return = Type.intInf,
 			    writesStackTop = false}
-	    fun wordBinary s =
+	    fun wordBinary (s, sg) =
 	       let
 		  val t = word s
 	       in
 		  vanilla {args = Vector.new2 (t, t),
 			   name = name,
+			   prototype = let
+					  val t = CType.word (s, sg)
+				       in
+					  (Vector.new2 (t, t), SOME t)
+				       end,
 			   return = t}
 	       end
-	    fun wordCompare s =
+	    fun wordCompare (s, sg) =
 	       vanilla {args = Vector.new2 (word s, word s),
 			name = name,
+			prototype = let
+				       val t = CType.word (s, sg)
+				    in
+				       (Vector.new2 (t, t), SOME CType.bool)
+				    end,
 			return = Type.bool}
-	    fun wordShift s =
+	    fun wordShift (s, sg) =
 	       vanilla {args = Vector.new2 (word s, Type.defaultWord),
 			name = name,
+			prototype = let
+				       open CType
+				    in
+				       (Vector.new2 (word (s, sg), Word32),
+					SOME bool)
+				    end,
 			return = word s}
 	    fun wordUnary s =
 	       vanilla {args = Vector.new1 (word s),
 			name = name,
+			prototype = let
+				       open CType
+				       val t = word (s, {signed = false})
+				    in
+				       (Vector.new1 t, SOME t)
+				    end,
 			return = word s}
 	 in
 	    case n of
@@ -292,10 +408,22 @@
 	     | IntInf_compare => 
 		  vanilla {args = Vector.new2 (Type.intInf, Type.intInf),
 			   name = name,
+			   prototype = let
+					  open CType
+				       in
+					  (Vector.new2 (Pointer, Pointer),
+					   SOME Int32)
+				       end,
 			   return = Type.defaultWord}
 	     | IntInf_equal =>
 		  vanilla {args = Vector.new2 (Type.intInf, Type.intInf),
 			   name = name,
+			   prototype = let
+					  open CType
+				       in
+					  (Vector.new2 (Pointer, Pointer),
+					   SOME bool)
+				       end,
 			   return = Type.bool}
 	     | IntInf_gcd => intInfBinary ()
 	     | IntInf_lshift => intInfShift ()
@@ -310,30 +438,31 @@
 	     | IntInf_xorb => intInfBinary ()
 	     | MLton_bug => CFunction.bug
 	     | Thread_returnToC => CFunction.returnToC
-	     | 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_add s => wordBinary (s, {signed = false})
+	     | Word_andb s => wordBinary (s, {signed = false})
+	     | Word_equal s => wordCompare (s, {signed = false})
+	     | Word_ge z => wordCompare z
+	     | Word_gt z => wordCompare z
+	     | Word_le z => wordCompare z
+	     | Word_lshift s => wordShift (s, {signed = false})
+	     | Word_lt z => wordCompare z
+	     | Word_mul z => wordBinary z
 	     | 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, _) =>
+	     | Word_orb s => wordBinary (s, {signed = false})
+	     | Word_quot z => wordBinary z
+	     | Word_rem z => wordBinary z
+	     | Word_rol s => wordShift (s, {signed = false})
+	     | Word_ror s => wordShift (s, {signed = false})
+	     | Word_rshift z => wordShift z
+	     | Word_sub s => wordBinary (s, {signed = false})
+	     | Word_toReal (s1, s2, sg) =>
+		  coerce (Type.word (WordSize.bits s1), Type.real s2, sg)
+	     | Word_toWord (s1, s2, sg) =>
 		  coerce (Type.word (WordSize.bits s1),
-			  Type.word (WordSize.bits s2))
-	     | Word_xorb s => wordBinary s
+			  Type.word (WordSize.bits s2),
+			  sg)
+	     | Word_xorb s => wordBinary (s, {signed = false})
 	     | _ => raise Fail "cFunctionRaise"
 	 end
 



1.92      +16 -14    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.91
retrieving revision 1.92
diff -u -r1.91 -r1.92
--- c-codegen.fun	31 Aug 2004 04:56:38 -0000	1.91
+++ c-codegen.fun	7 Sep 2004 00:46:19 -0000	1.92
@@ -40,24 +40,26 @@
    struct
       open CFunction
 	 
-      fun prototype (T {args, convention, name, return, ...}) =
+      fun prototype (T {convention, name, prototype = (args, return), ...}) =
 	 let
+	    val attributes =
+	       if convention <> Convention.Cdecl
+		  then concat [" __attribute__ ((",
+			       Convention.toString convention,
+			       ")) "]
+	       else " "
 	    val c = Counter.new 0
-	    fun arg t = concat [CType.toString (Type.toCType t),
-				" x", Int.toString (Counter.next c)]
+	    fun arg t =
+	       concat [CType.toString t, " x", Int.toString (Counter.next c)]
+	    val return =
+	       case return of
+		  NONE => "void"
+		| SOME t => CType.toString t
 	 in
 	    concat
-	    [if Type.isUnit return
-		then "void"
-	     else CType.toString (Type.toCType return),
-		if convention <> Convention.Cdecl
-		   then concat [" __attribute__ ((",
-				Convention.toString convention,
-				")) "]
-		else " ",
-		   name, " (",
-		   concat (List.separate (Vector.toListMap (args, arg), ", ")),
-		   ")"]
+	    [return, attributes, name,
+	     " (", concat (List.separate (Vector.toListMap (args, arg), ", ")),
+	     ")"]
 	 end
    end
 



1.31      +24 -36    mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun

Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- x86-mlton-basic.fun	25 Aug 2004 17:51:08 -0000	1.30
+++ x86-mlton-basic.fun	7 Sep 2004 00:46:19 -0000	1.31
@@ -301,43 +301,31 @@
 
 
   local
-     fun make name size =
-	Label.fromString (concat ["local", name, size])
-     val r = make "Real"
-     val w = make "Word"
-     datatype z = datatype CType.t
+     fun make prefix =
+	let
+	   fun make name size = Label.fromString (concat [prefix, name, size])
+	   val r = make "Real"
+	   val w = make "Word"
+	   datatype z = datatype CType.t
+	in
+	   CType.memo
+	   (fn t =>
+	    case t of
+	       Int8 => w "8"
+	     | Int16 => w "16"
+	     | Int32 => w "32"
+	     | Int64 => w "64"
+	     | Pointer => Label.fromString (concat [prefix, "Pointer"])
+	     | Real32 => r "32"
+	     | Real64 => r "64"
+	     | Word8 => w "8"
+	     | Word16 => w "16"
+	     | Word32 => w "32"
+	     | Word64 => w "64")
+	end
   in
-     val local_base =
-	CType.memo
-	(fn t =>
-	 case t of
-	    Pointer => Label.fromString "localPointer"
-	  | Real32 => r "32"
-	  | Real64 => r "64"
-	  | Word8 => w "8"
-	  | Word16 => w "16"
-	  | Word32 => w "32"
-	  | Word64 => w "64")
-  end
-
-  local
-     fun make name size =
-	Label.fromString (concat ["global", name, size])
-     val r = make "Real"
-     val w = make "Word"
-    datatype z = datatype CType.t
-  in
-     val global_base =
-	CType.memo
-	(fn t =>
-	 case t of
-	    Pointer => Label.fromString "globalPointer"
-	  | Real32 => r "32"
-	  | Real64 => r "64"
-	  | Word8 => w "8"
-	  | Word16 => w "16"
-	  | Word32 => w "32"
-	  | Word64 => w "64")
+     val local_base = make "local"
+     val global_base = make "global"
   end
 
   val globalPointerNonRoot_base = Label.fromString "globalPointerNonRoot"



1.56      +36 -19    mlton/mlton/codegen/x86-codegen/x86.fun

Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- x86.fun	25 Aug 2004 17:51:08 -0000	1.55
+++ x86.fun	7 Sep 2004 00:46:19 -0000	1.56
@@ -126,7 +126,11 @@
       in
 	 fun fromCType t =
 	    case t of
-	       Pointer => Vector.new1 LONG
+	       Int8 => Vector.new1 BYTE
+	     | Int16 => Vector.new1 WORD
+	     | Int32 => Vector.new1 LONG
+	     | Int64 => Vector.new2 (LONG, LONG)
+	     | Pointer => Vector.new1 LONG
 	     | Real32 => Vector.new1 SNGL
 	     | Real64 => Vector.new1 DBLE
 	     | Word8 => Vector.new1 BYTE
@@ -667,7 +671,11 @@
       in
 	 fun fromCType t =
 	    case t of
-	       Pointer => Four
+	       Int8 => One
+	     | Int16 => Two
+	     | Int32 => Four
+	     | Int64 => Eight
+	     | Pointer => Four
 	     | Real32 => Four
 	     | Real64 => Eight
 	     | Word8 => One
@@ -1394,23 +1402,32 @@
 	    if RepType.isUnit ty
 	       then []
 	    else
-	       case RepType.toCType ty of
-		  Pointer => [{src = register Register.eax,
-			       dst = cReturnTempContent (0, LONG)}]
-		| Real32 => [{src = fltregister FltRegister.top,
-			      dst = cReturnTempContent (0, SNGL)}]
-		| Real64 => [{src = fltregister FltRegister.top,
-			      dst = cReturnTempContent (0, DBLE)}]
-		| Word8 => [{src = register Register.al,
-			     dst = cReturnTempContent (0, BYTE)}]
-		| Word16 => [{src = register Register.ax,
-			      dst = cReturnTempContent (0, WORD)}]
-		| Word32 => [{src = register Register.eax,
-			      dst = cReturnTempContent (0, LONG)}]
-		| Word64 => [{src = register Register.eax,
-			      dst = cReturnTempContent (0, LONG)},
-			     {src = register Register.edx,
-			      dst = cReturnTempContent (4, LONG)}]
+	       let
+		  fun w (r, s) =
+		     [{src = register r, dst = cReturnTempContent (0, s)}]
+		  val w8 = w (Register.al, BYTE)
+		  val w16 = w (Register.ax, WORD)
+		  val w32 = w (Register.eax, LONG)
+		  val w64 =[{src = register Register.eax,
+			     dst = cReturnTempContent (0, LONG)},
+			    {src = register Register.edx,
+			     dst = cReturnTempContent (4, LONG)}]
+	       in
+		  case RepType.toCType ty of
+		     Int8 => w8
+		   | Int16 => w16
+		   | Int32 => w32
+		   | Int64 => w64
+		   | Pointer => w32
+		   | Real32 => [{src = fltregister FltRegister.top,
+				 dst = cReturnTempContent (0, SNGL)}]
+		   | Real64 => [{src = fltregister FltRegister.top,
+				 dst = cReturnTempContent (0, DBLE)}]
+		   | Word8 => w8
+		   | Word16 => w16
+		   | Word32 => w32
+		   | Word64 => w64
+	       end
       end
     end
 



1.119     +16 -5     mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.118
retrieving revision 1.119
diff -u -r1.118 -r1.119
--- elaborate-core.fun	25 Aug 2004 17:51:10 -0000	1.118
+++ elaborate-core.fun	7 Sep 2004 00:46:20 -0000	1.119
@@ -652,10 +652,9 @@
 
       val nullary: (string * CType.t * Tycon.t) list =
 	 let
-	    fun sized (tycon: Bits.t -> Tycon.t) =
+	    fun sized (tycon: Bits.t -> Tycon.t, ctypes) =
 	       List.map
-	       ([CType.Word8, CType.Word16, CType.Word32, CType.Word64],
-		fn cty =>
+	       (ctypes, fn cty =>
 		let
 		   val c = tycon (Bytes.toBits (CType.size cty))
 		   val s = Tycon.toString c
@@ -675,10 +674,20 @@
 	     ("Char", CType.char, Tycon.char),
 	     ("Pointer", CType.preThread, Tycon.preThread),
 	     ("Thread", CType.thread, Tycon.thread)]
-	    @ sized (Tycon.int o IntSize.I)
+	    @ sized (Tycon.int o IntSize.I,
+		     let
+			open CType
+		     in
+			[Int8, Int16, Int32, Int64]
+		     end)
 	    @ [("Real32", CType.Real32, Tycon.real RealSize.R32),
 	       ("Real64", CType.Real64, Tycon.real RealSize.R64)]
-	    @ sized (Tycon.word o WordSize.fromBits)
+	    @ sized (Tycon.word o WordSize.fromBits,
+		     let
+			open CType
+		     in
+			[Word8, Word16, Word32, Word64]
+		     end)
 	 end
 
       val nullary =
@@ -812,6 +821,8 @@
 			       mayGC = true,
 			       maySwitchThreads = false,
 			       name = name,
+			       prototype = (Vector.map (args, #ctype),
+					    Option.map (result, #ctype)),
 			       readsStackTop = true,
 			       return = (case result of
 					    NONE => Type.unit



1.5       +1 -1      mlton/runtime/platform.h

Index: platform.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform.h,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- platform.h	4 Sep 2004 04:07:12 -0000	1.4
+++ platform.h	7 Sep 2004 00:46:20 -0000	1.5
@@ -306,7 +306,7 @@
 
 Word IntInf_smallMul (Word lhs, Word rhs, Pointer carry);
 Int IntInf_compare (Pointer lhs, Pointer rhs);
-Int IntInf_equal (Pointer lhs, Pointer rhs);
+Bool IntInf_equal (Pointer lhs, Pointer rhs);
 
 /* ------------------------------------------------- */
 /*                      Itimer                       */



1.18      +1 -1      mlton/runtime/basis/IntInf.c

Index: IntInf.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/IntInf.c,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- IntInf.c	25 Aug 2004 17:51:16 -0000	1.17
+++ IntInf.c	7 Sep 2004 00:46:20 -0000	1.18
@@ -330,7 +330,7 @@
 /*
  * Check if two IntInf.int's are equal.
  */
-Int IntInf_equal (pointer lhs, pointer rhs) {
+Bool IntInf_equal (pointer lhs, pointer rhs) {
 	if (lhs == rhs)
 		return TRUE;
 	if (eitherIsSmall (lhs, rhs))