[MLton] cvs commit: changed typing for C functions

Stephen Weeks sweeks@mlton.org
Mon, 12 Apr 2004 10:53:11 -0700


sweeks      04/04/12 10:53:08

  Modified:    mlton/ast prim-tycons.fun prim-tycons.sig
               mlton/atoms atoms.fun atoms.sig c-function.fun
                        c-function.sig c-type.fun c-type.sig ffi.sig
                        hash-type.fun hash-type.sig prim.fun prim.sig
                        rep-type.fun rep-type.sig sources.cm type-ops.fun
                        type-ops.sig
               mlton/backend backend.fun limit-check.fun machine.fun
                        machine.sig profile.fun rssa.fun rssa.sig
                        signal-check.fun ssa-to-rssa.fun
               mlton/closure-convert abstract-value.fun abstract-value.sig
                        closure-convert.fun closure-convert.sig
               mlton/codegen/c-codegen c-codegen.fun
               mlton/codegen/x86-codegen x86-mlton-basic.fun
                        x86-mlton-basic.sig x86-mlton.fun x86-mlton.sig
                        x86-pseudo.sig x86.fun x86.sig
               mlton/core-ml core-ml.fun core-ml.sig
               mlton/defunctorize defunctorize.fun
               mlton/elaborate elaborate-core.fun type-env.fun
               mlton/ssa analyze.sig direct-exp.fun direct-exp.sig
                        redundant-tests.fun shrink.fun ssa-tree.fun
                        ssa-tree.sig type-check.fun
               mlton/xml implement-exceptions.fun monomorphise.fun
                        simplify-types.fun type-check.fun xml-tree.fun
                        xml-tree.sig
  Log:
  MAIL changed typing for C functions
  
  Another overhaul of types for C functions.  Now, CFunction.t is
  polymorphic in the type used for its arguments and result.  Each IL
  fills in the type needed for its type system.  The types are
  translated by each pass, ending up with representation types in the
  Rssa and Machine.
  
  Because C functions are treated as primitives in XML and SSA,
  primitives are now also polymorphic in the type.
  
  Improved type checking of primapps.
  
  Removed primitive pointer tycon (for C pointers) and associated types.
  The basis library uses Word32.word.

Revision  Changes    Path
1.22      +0 -2      mlton/mlton/ast/prim-tycons.fun

Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- prim-tycons.fun	4 Apr 2004 06:50:14 -0000	1.21
+++ prim-tycons.fun	12 Apr 2004 17:52:46 -0000	1.22
@@ -23,7 +23,6 @@
 val exn = fromString "exn"
 val intInf = fromString "intInf"
 val list = fromString "list"
-val pointer = fromString "pointer"
 val preThread = fromString "preThread"
 val reff = fromString "ref"
 val thread = fromString "thread"
@@ -91,7 +90,6 @@
     (exn, Arity 0, Never),
     (intInf, Arity 0, Always),
     (list, Arity 1, Sometimes),
-    (pointer, Arity 0, Always),
     (preThread, Arity 0, Never),
     (reff, Arity 1, Always),
     (thread, Arity 0, Never),



1.12      +0 -1      mlton/mlton/ast/prim-tycons.sig

Index: prim-tycons.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- prim-tycons.sig	18 Mar 2004 03:22:21 -0000	1.11
+++ prim-tycons.sig	12 Apr 2004 17:52:46 -0000	1.12
@@ -48,7 +48,6 @@
 	 tycon * (Layout.t * {isChar: bool, needsParen: bool}) vector
 	 -> Layout.t * {isChar: bool, needsParen: bool}
       val list: tycon
-      val pointer: tycon
       val preThread: tycon
       val prims: (tycon * Kind.t * AdmitsEquality.t) list
       val real: RealSize.t -> tycon



1.15      +11 -10    mlton/mlton/atoms/atoms.fun

Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- atoms.fun	4 Apr 2004 06:50:14 -0000	1.14
+++ atoms.fun	12 Apr 2004 17:52:47 -0000	1.15
@@ -42,24 +42,25 @@
       structure Const = Const (structure IntX = IntX
 			       structure RealX = RealX
 			       structure WordX = WordX)
-      structure RepType = RepType (structure CType = CType
+      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 RepType = RepType (structure CFunction = CFunction
+				   structure CType = CType
 				   structure IntSize = IntSize
 				   structure IntX = IntX
 				   structure Label = Label
 				   structure PointerTycon = PointerTycon
+				   structure Prim = Prim
 				   structure RealSize = RealSize
 				   structure Runtime = Runtime
 				   structure WordSize = WordSize
 				   structure WordX = WordX)
-      structure CFunction = CFunction (structure RepType = RepType)
-      structure Prim = Prim (structure CFunction = CFunction
-			     structure CType = CType
-			     structure Con = Con
-			     structure Const = Const
-			     structure IntSize = IntSize
-			     structure RealSize = RealSize
-			     structure RepType = RepType
-			     structure WordSize = WordSize)
       structure Ffi = Ffi (structure CFunction = CFunction
 			   structure CType = CType)
       structure ObjectType = RepType.ObjectType



1.16      +1 -1      mlton/mlton/atoms/atoms.sig

Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- atoms.sig	4 Apr 2004 06:50:14 -0000	1.15
+++ atoms.sig	12 Apr 2004 17:52:47 -0000	1.16
@@ -56,9 +56,9 @@
       sharing Label = RepType.Label
       sharing ObjectType = RepType.ObjectType
       sharing PointerTycon = ObjectType.PointerTycon = RepType.PointerTycon
+      sharing Prim = RepType.Prim
       sharing RealSize = Prim.RealSize = RealX.RealSize = RepType.RealSize
 	 = Tycon.RealSize
-      sharing RepType = CFunction.RepType = Prim.RepType
       sharing RealX = Const.RealX
       sharing Runtime = ObjectType.Runtime = RepType.Runtime
       sharing SourceInfo = ProfileExp.SourceInfo



1.6       +42 -132   mlton/mlton/atoms/c-function.fun

Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- c-function.fun	4 Apr 2004 06:50:14 -0000	1.5
+++ c-function.fun	12 Apr 2004 17:52:48 -0000	1.6
@@ -3,17 +3,6 @@
 
 open S
 
-structure Type = RepType
-structure CType = Type.CType
-
-local
-   open Type
-in
-   structure IntSize = IntSize
-   structure RealSize = RealSize
-   structure WordSize = WordSize
-end
-
 structure Convention =
    struct
       datatype t =
@@ -27,22 +16,23 @@
       val layout = Layout.str o toString
    end
 
-datatype t = T of {args: Type.t vector,
-		   bytesNeeded: int option,
-		   convention: Convention.t,
-		   ensuresBytesFree: bool,
-		   mayGC: bool,
-		   maySwitchThreads: bool,
-		   modifiesFrontier: bool,
-		   modifiesStackTop: bool,
-		   name: string,
-		   return: Type.t}
+datatype 'a t = T of {args: 'a vector,
+		      bytesNeeded: int option,
+		      convention: Convention.t,
+		      ensuresBytesFree: bool,
+		      mayGC: bool,
+		      maySwitchThreads: bool,
+		      modifiesFrontier: bool,
+		      modifiesStackTop: bool,
+		      name: string,
+		      return: 'a}
    
 fun layout (T {args, bytesNeeded, convention, ensuresBytesFree, mayGC,
 	       maySwitchThreads, modifiesFrontier, modifiesStackTop, name,
-	       return, ...}) =
+	       return, ...},
+	    layoutType) =
    Layout.record
-   [("args", Vector.layout Type.layout args),
+   [("args", Vector.layout layoutType args),
     ("bytesNeeded", Option.layout Int.layout bytesNeeded),
     ("convention", Convention.layout convention),
     ("ensuresBytesFree", Bool.layout ensuresBytesFree),
@@ -51,28 +41,44 @@
     ("modifiesFrontier", Bool.layout modifiesFrontier),
     ("modifiesStackTop", Bool.layout modifiesStackTop),
     ("name", String.layout name),
-    ("return", Type.layout return)]
+    ("return", layoutType return)]
    
 local
    fun make f (T r) = f r
 in
-   val args = make #args
-   val bytesNeeded = make #bytesNeeded
-   val ensuresBytesFree = make #ensuresBytesFree
-   val mayGC = make #mayGC
-   val maySwitchThreads = make #maySwitchThreads
-   val modifiesFrontier = make #modifiesFrontier
-   val modifiesStackTop = make #modifiesStackTop
-   val name = make #name
-   val return = make #return
+   fun args z = make #args z
+   fun bytesNeeded z = make #bytesNeeded z
+   fun ensuresBytesFree z = make #ensuresBytesFree z
+   fun mayGC z = make #mayGC z
+   fun maySwitchThreads z = make #maySwitchThreads z
+   fun modifiesFrontier z = make #modifiesFrontier z
+   fun modifiesStackTop z = make #modifiesStackTop z
+   fun name z = make #name z
+   fun return z = make #return z
 end
 
 fun equals (f, f') = name f = name f'
 
+fun map (T {args, bytesNeeded, convention, ensuresBytesFree, mayGC,
+	    maySwitchThreads, modifiesFrontier, modifiesStackTop, name,
+	    return},
+	 f) =
+   T {args = Vector.map (args, f),
+      bytesNeeded = bytesNeeded,
+      convention = convention,
+      ensuresBytesFree = ensuresBytesFree,
+      mayGC = mayGC,
+      maySwitchThreads = maySwitchThreads,
+      modifiesFrontier = modifiesFrontier,
+      modifiesStackTop = modifiesStackTop,
+      name = name,
+      return = f return}
+   
 fun isOk (T {ensuresBytesFree, mayGC, maySwitchThreads, modifiesFrontier,
-	     modifiesStackTop, return, ...}): bool =
+	     modifiesStackTop, return, ...},
+	  {isUnit}): bool =
    (if maySwitchThreads
-       then mayGC andalso RepType.isUnit return
+       then mayGC andalso isUnit return
     else true)
        andalso
        (if ensuresBytesFree orelse maySwitchThreads
@@ -82,52 +88,11 @@
 	   (if mayGC
 	       then (modifiesFrontier andalso modifiesStackTop)
 	    else true)
-	     
-val isOk = Trace.trace ("CFunction.isOk", layout, Bool.layout) isOk
-
-val equals =
-   Trace.trace2 ("CFunction.equals", layout, layout, Bool.layout) equals
-
-datatype z = datatype Convention.t
-
-local
-   open Type
-in
-   val Int32 = int (IntSize.I (Bits.fromInt 32))
-   val Word32 = word (Bits.fromInt 32)
-   val bool = bool
-   val cPointer = cPointer
-   val gcState = gcState
-   val string = word8Vector
-   val unit = unit
-end
-   
-local
-   fun make b =
-      T {args = let
-		   open Type
-		in
-		   Vector.new5 (gcState, Word32, bool, cPointer (), Int32)
-		end,
-	  bytesNeeded = NONE,
-	     convention = Cdecl,
-	     ensuresBytesFree = true,
-	     mayGC = true,
-	     maySwitchThreads = b,
-	     modifiesFrontier = true,
-	     modifiesStackTop = true,
-	     name = "GC_gc",
-	     return = unit}
-   val t = make true
-   val f = make false
-in
-   fun gc {maySwitchThreads = b} = if b then t else f
-end
 
 fun vanilla {args, name, return} =
    T {args = args,
       bytesNeeded = NONE,
-      convention = Cdecl,
+      convention = Convention.Cdecl,
       ensuresBytesFree = false,
       mayGC = false,
       maySwitchThreads = false,
@@ -135,60 +100,5 @@
       modifiesStackTop = false,
       name = name,
       return = return}
-
-val allocTooLarge =
-   vanilla {args = Vector.new0 (),
-	    name = "MLton_allocTooLarge",
-	    return = unit}
-   
-val bug = vanilla {args = Vector.new1 string,
-		   name = "MLton_bug",
-		   return = unit}
-
-val profileEnter =
-   vanilla {args = Vector.new1 gcState,
-	    name = "GC_profileEnter",
-	    return = unit}
-
-val profileInc =
-   vanilla {args = Vector.new2 (gcState, Word32),
-	    name = "GC_profileInc",
-	    return = unit}
-	 
-val profileLeave =
-   vanilla {args = Vector.new1 gcState,
-	    name = "GC_profileLeave",
-	    return = unit}
-
-val returnToC =
-   T {args = Vector.new0 (),
-      bytesNeeded = NONE,
-      convention = Cdecl,
-      ensuresBytesFree = false,
-      modifiesFrontier = true,
-      modifiesStackTop = true,
-      mayGC = true,
-      maySwitchThreads = true,
-      name = "Thread_returnToC",
-      return = unit}
-
-fun prototype (T {args, convention, name, return, ...}) =
-   let
-      val c = Counter.new 0
-      fun arg t = concat [CType.toString (Type.toCType t),
-			  " x", Int.toString (Counter.next c)]
-   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), ", ")),
-	      ")"]
-   end
 
 end



1.3       +33 -46    mlton/mlton/atoms/c-function.sig

Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- c-function.sig	4 Apr 2004 06:50:14 -0000	1.2
+++ c-function.sig	12 Apr 2004 17:52:48 -0000	1.3
@@ -9,13 +9,12 @@
    
 signature C_FUNCTION_STRUCTS = 
    sig
-      structure RepType: REP_TYPE
    end
 
 signature C_FUNCTION = 
    sig
       include C_FUNCTION_STRUCTS
-      
+
       structure Convention:
 	 sig
 	    datatype t = Cdecl | Stdcall
@@ -24,50 +23,38 @@
 	    val toString: t -> string
 	 end
 
-      datatype t = T of {args: RepType.t vector,
-			 (* bytesNeeded = SOME i means that the i'th
-			  * argument to the function is a word that
-			  * specifies the number of bytes that must be
-			  * free in order for the C function to succeed.
-			  * Limit check insertion is responsible for
-			  * making sure that the bytesNeeded is available.
-			  *)
-			 bytesNeeded: int option,
-			 convention: Convention.t,
-			 ensuresBytesFree: bool,
-			 mayGC: bool,
-			 maySwitchThreads: bool,
-			 modifiesFrontier: bool,
-			 modifiesStackTop: bool,
-			 name: string,
-			 return: RepType.t}
+      datatype 'a t = T of {args: 'a vector,
+			     (* bytesNeeded = SOME i means that the i'th
+			      * argument to the function is a word that
+			      * specifies the number of bytes that must be
+			      * free in order for the C function to succeed.
+			      * Limit check insertion is responsible for
+			      * making sure that the bytesNeeded is available.
+			      *)
+			     bytesNeeded: int option,
+			     convention: Convention.t,
+			     ensuresBytesFree: bool,
+			     mayGC: bool,
+			     maySwitchThreads: bool,
+			     modifiesFrontier: bool,
+			     modifiesStackTop: bool,
+			     name: string,
+			     return: 'a}
 
-      val allocTooLarge: t
-      val args: t -> RepType.t vector
-      val bug: t
-      val bytesNeeded: t -> int option
-      val ensuresBytesFree: t -> bool
-      val equals: t * t -> bool
-      val gc: {maySwitchThreads: bool} -> t
-      val isOk: t -> bool
-      val layout: t -> Layout.t
-      val mayGC: t -> bool
-      val maySwitchThreads: t -> bool
-      val modifiesFrontier: t -> bool
-      val modifiesStackTop: t -> bool
-      val name: t -> string
-      val profileEnter: t
-      val profileInc: t
-      val profileLeave: t
-      val prototype: t -> string
-      val return: t -> RepType.t
-      (* returnToC is not really a C function.  Calls to it must be handled
-       * specially by each codegen to ensure that the C stack is handled
-       * correctly.  However, for the purposes of everything up to the
-       * backend it looks like a call to C.
-       *)
-      val returnToC: t
-      val vanilla: {args: RepType.t vector,
+      val args: 'a t -> 'a vector
+      val bytesNeeded: 'a t -> int option
+      val ensuresBytesFree: 'a t -> bool
+      val equals: 'a t * 'a t -> bool
+      val isOk: 'a t * {isUnit: 'a -> bool} -> bool
+      val layout: 'a t * ('a -> Layout.t) -> Layout.t
+      val map: 'a t * ('a -> 'b) -> 'b t
+      val mayGC: 'a t -> bool
+      val maySwitchThreads: 'a t -> bool
+      val modifiesFrontier: 'a t -> bool
+      val modifiesStackTop: 'a t -> bool
+      val name: 'a t -> string
+      val return: 'a t -> 'a
+      val vanilla: {args: 'a vector,
 		    name: string,
-		    return: RepType.t} -> t
+		    return: 'a} -> 'a t
    end



1.5       +10 -0     mlton/mlton/atoms/c-type.fun

Index: c-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- c-type.fun	4 Apr 2004 06:50:14 -0000	1.4
+++ c-type.fun	12 Apr 2004 17:52:48 -0000	1.5
@@ -14,6 +14,16 @@
 
 val all = [Pointer, Real32, Real64, Word8, Word16, Word32, Word64]
 
+val bool = Word32
+
+val char = Word8
+
+val pointer = Pointer
+
+val preThread = Pointer
+   
+val thread = Pointer
+
 val equals: t * t -> bool = op =
    
 fun memo (f: t -> 'a): t -> 'a =



1.5       +12 -0     mlton/mlton/atoms/c-type.sig

Index: c-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- c-type.sig	4 Apr 2004 06:50:14 -0000	1.4
+++ c-type.sig	12 Apr 2004 17:52:48 -0000	1.5
@@ -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.
+ *)
+
 type int = Int.t
    
 signature C_TYPE_STRUCTS = 
@@ -19,11 +26,16 @@
 
       val align: t * Bytes.t -> Bytes.t
       val all: t list
+      val bool: t
+      val char: t
       val equals: t * t -> bool
       val memo: (t -> 'a) -> t -> 'a
       (* name: R{32,64} W{8,16,32,64} *)
       val name: t -> string
       val layout: t -> Layout.t
+      val pointer: t
+      val preThread: t
       val size: t -> Bytes.t
+      val thread: t
       val toString: t -> string
    end



1.6       +0 -1      mlton/mlton/atoms/ffi.sig

Index: ffi.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- ffi.sig	4 Apr 2004 06:50:14 -0000	1.5
+++ ffi.sig	12 Apr 2004 17:52:48 -0000	1.6
@@ -11,7 +11,6 @@
    sig
       structure CFunction: C_FUNCTION
       structure CType: C_TYPE
-      sharing CType = CFunction.RepType.CType
    end
 
 signature FFI = 



1.12      +186 -125  mlton/mlton/atoms/hash-type.fun

Index: hash-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- hash-type.fun	4 Apr 2004 06:50:14 -0000	1.11
+++ hash-type.fun	12 Apr 2004 17:52:48 -0000	1.12
@@ -205,136 +205,197 @@
 	con = fn (tycon', bs) => (Tycon.equals (tycon, tycon')
 				  orelse Vector.exists (bs, fn b => b))}
 
-structure P = PointerTycon
-   
-fun fromRepType (t: RepType.t): t =
+fun checkPrimApp {args, prim, result, targs}: bool =
    let
-      fun bug () = Error.bug (concat ["Type.fromRepType: ", RepType.toString t])
-      datatype z = datatype RepType.dest
-   in
-      case RepType.dest t of
-	 Int s => int s
-       | Real s => real s
-       | Pointer p =>
-	    (case List.peek ([(P.thread, thread),
-			      (P.word8Vector, word8Vector)],
-			     fn (p', _) => P.equals (p, p')) of
-		NONE => bug ()
-	      | SOME (_, t) => t)
-       | Seq ts => if 0 = Vector.length ts then unit else bug ()
-       | Sum _ => if RepType.isBool t then bool else bug ()
-       | Word s => word (WordSize.fromBits s)
-       | _ => bug ()
-   end
-
-val fromRepType =
-   Trace.trace ("Type.fromRepType", RepType.layout, layout) fromRepType
-
-local
-   val {get, set, ...} =
-      Property.getSetOnce (Tycon.plist, Property.initConst NONE)
-   val () =
-      List.foreach ([Tycon.array, Tycon.reff, Tycon.vector], fn t =>
-		    set (t, SOME (RepType.cPointer ())))
-   fun doit (ts, f) = Vector.foreach (ts, fn (c, s) => set (c, SOME (f s)))
-   val () = doit (Tycon.ints, RepType.int)
-   val () = doit (Tycon.reals, RepType.real)
-   val () = set (Tycon.thread, SOME RepType.thread)
-   val () = doit (Tycon.words, RepType.word o WordSize.bits)
-in
-   fun toRepType (t: t): RepType.t =
-      let
-	 fun bug () = Error.bug (concat ["Type.toRepType: ", toString t])
+      datatype z = datatype Prim.Name.t
+      fun done (args', result') =
+	 Vector.equals (args, Vector.fromList args', equals)
+	 andalso equals (result, result')
+      fun targ i = Vector.sub (targs, i)
+      fun oneTarg f =
+	 1 = Vector.length targs
+	 andalso done (f (targ 0))
+      local
+	 fun make f s = let val t = f s in done ([t], t) end
       in
-	 case dest t of
-	    Con (c, _) =>
-	       (case get c of
-		   NONE => bug ()
-		 | SOME t => t)
-	  | Var _ => bug ()
+	 val intUnary = make int
+	 val realUnary = make real
+	 val wordUnary = make word
       end
-end
-
-fun checkPrimApp {args, prim, result}: bool =
-   let
-      fun check () =
-	 case Prim.typeCheck (prim, Vector.map (args, toRepType)) of
-	    NONE => false
-	  | SOME t => equals (result, fromRepType t)
-      datatype z = datatype Prim.Name.t
+      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
+      fun intInfBinary () = done ([intInf, intInf, defaultWord], intInf)
+      fun intInfShift () = done ([intInf, defaultWord, defaultWord], intInf)
+      fun intInfUnary () = done ([intInf, defaultWord], intInf)
+      fun real3 s = done ([real s, real s, real s], real s)
+      val pointer = defaultWord
+      val word8Array = array word8
+      val wordVector = vector defaultWord
+      fun wordShift s = done ([word s, defaultWord], word s)
    in
       case Prim.name prim of
-	 Array_array => true
-       | Array_array0Const => true
-       | Array_length => true
-       | Array_sub => true
-       | Array_toVector => true
-       | Array_update => true
-       | Exn_extra => true
-       | Exn_name => true
-       | Exn_setExtendExtra => true
-       | Exn_setInitExtra => true
-       | Exn_setTopLevelHandler => true
-       | GC_collect => true
-       | GC_pack => true
-       | GC_unpack => true
-       | IntInf_add => true
-       | IntInf_andb => true
-       | IntInf_arshift => true
-       | IntInf_compare => true
-       | IntInf_equal => true
-       | IntInf_gcd => true
-       | IntInf_lshift => true
-       | IntInf_mul => true
-       | IntInf_neg => true
-       | IntInf_notb => true
-       | IntInf_orb => true
-       | IntInf_quot => true
-       | IntInf_rem => true
-       | IntInf_sub => true
-       | IntInf_toString => true
-       | IntInf_toVector => true
-       | IntInf_toWord => true
-       | IntInf_xorb => true
-       | MLton_bogus => true
-       | MLton_bug => true
-       | MLton_eq => true
-       | MLton_equal => true
-       | MLton_halt => true
-       | MLton_handlesSignals => true
-       | MLton_installSignalHandler => true
-       | MLton_size => true
-       | MLton_touch => true
-       | Pointer_getInt _ => true
-       | Pointer_getPointer => true
-       | Pointer_getReal _ => true
-       | Pointer_getWord _ => true
-       | Pointer_setInt _ => true
-       | Pointer_setPointer => true
-       | Pointer_setReal _ => true
-       | Pointer_setWord _ => true
-       | Ref_assign => true
-       | Ref_deref => true
-       | Ref_ref => true
-       | Thread_atomicBegin => true
-       | Thread_atomicEnd => true
-       | Thread_canHandle => true
-       | Thread_copy => true
-       | Thread_copyCurrent => true
-       | Thread_returnToC => true
-       | Thread_switchTo => true
-       | Vector_length => true
-       | Vector_sub => true
-       | Weak_canGet => true
-       | Weak_get => true
-       | Weak_new => true
-       | Word_toIntInf => true
-       | WordVector_toIntInf => true
-       | Word8Array_subWord => true
-       | Word8Array_updateWord => true
-       | Word8Vector_subWord => true
-       | World_save => true
-       | _ => check ()
+	 Array_array => oneTarg (fn targ => ([defaultInt], 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_toVector => oneTarg (fn t => ([array t], vector t))
+       | Array_update => oneTarg (fn t => ([array t, defaultInt, t], unit))
+       | Exn_extra => oneTarg (fn t => ([exn], t))
+       | Exn_name => done ([exn], string)
+       | Exn_setExtendExtra =>
+	    oneTarg (fn t => ([arrow (tuple (Vector.new2 (string, t)), t)],
+			      unit))
+       | Exn_setInitExtra => oneTarg (fn t => ([t], unit))
+       | Exn_setTopLevelHandler => done ([arrow (exn, unit)], unit)
+       | FFI f => done (Vector.toList (CFunction.args f), CFunction.return f)
+       | FFI_Symbol {ty, ...} => done ([], ty)
+       | GC_collect => done ([], unit)
+       | GC_pack => done ([], unit)
+       | GC_unpack => done ([], unit)
+       | IntInf_add => intInfBinary ()
+       | IntInf_andb => intInfBinary ()
+       | IntInf_arshift => intInfShift ()
+       | IntInf_compare => done ([intInf, intInf], defaultInt)
+       | IntInf_equal => done ([intInf, intInf], bool)
+       | 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 => done ([intInf, defaultInt, 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_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') => 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_handlesSignals => done ([], bool)
+       | MLton_installSignalHandler => done ([], unit)
+       | MLton_size => oneTarg (fn t => ([reff t], defaultInt))
+       | 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)
+       | Real_Math_acos s => realUnary s
+       | Real_Math_asin s => realUnary s
+       | Real_Math_atan s => realUnary s
+       | Real_Math_atan2 s => realBinary s
+       | Real_Math_cos s => realUnary s
+       | Real_Math_exp s => realUnary s
+       | Real_Math_ln s => realUnary s
+       | Real_Math_log10 s => realUnary s
+       | Real_Math_sin s => realUnary s
+       | Real_Math_sqrt s => realUnary s
+       | Real_Math_tan s => realUnary s
+       | Real_abs s => realUnary s
+       | Real_add s => realBinary s
+       | Real_div s => realBinary s
+       | 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_le s => realCompare s
+       | Real_lt s => realCompare s
+       | Real_mul s => realBinary s
+       | Real_muladd s => real3 s
+       | Real_mulsub s => real3 s
+       | Real_neg s => realUnary s
+       | 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')
+       | 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_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))
+       | 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_updateWord =>
+	    done ([word8Array, defaultInt, defaultWord], unit)
+       | Word8Vector_subWord => done ([word8Vector, defaultInt], defaultWord)
+       | WordVector_toIntInf => done ([wordVector], intInf)
+       | Word_add 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_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_neg s => wordUnary s
+       | Word_notb s => wordUnary s
+       | Word_orb s => wordBinary s
+       | Word_rol s => wordShift s
+       | Word_ror s => wordShift s
+       | Word_rshift s => wordShift s
+       | Word_sub s => wordBinary s
+       | Word_toInt (s, s') => done ([word s], int 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_xorb s => wordBinary s
+       | World_save => done ([defaultWord], unit)
+       | _ => Error.bug (concat ["Type.checkPrimApp got strange prim: ",
+				 Prim.toString prim])
    end
 
 end



1.7       +3 -2      mlton/mlton/atoms/hash-type.sig

Index: hash-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- hash-type.sig	4 Apr 2004 06:50:14 -0000	1.6
+++ hash-type.sig	12 Apr 2004 17:52:48 -0000	1.7
@@ -28,8 +28,9 @@
 	 end
 
       val checkPrimApp: {args: t vector,
-			 prim: Prim.t,
-			 result: t} -> bool
+			 prim: t Prim.t,
+			 result: t,
+			 targs: t vector} -> bool
       val containsTycon: t * Tycon.t -> bool
       (* O(1) time *)
       val equals: t * t -> bool



1.76      +213 -220  mlton/mlton/atoms/prim.fun

Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -r1.75 -r1.76
--- prim.fun	4 Apr 2004 06:50:14 -0000	1.75
+++ prim.fun	12 Apr 2004 17:52:48 -0000	1.76
@@ -33,7 +33,7 @@
        | SideEffect
    end
 
-datatype t =
+datatype 'a t =
    Array_array (* backend *)
  | Array_array0Const (* constant propagation *)
  | Array_length (* ssa to rssa *)
@@ -47,9 +47,9 @@
  | Exn_setExtendExtra (* implement exceptions *)
  | Exn_setInitExtra (* implement exceptions *)
  | Exn_setTopLevelHandler (* implement exceptions *)
- | FFI of CFunction.t (* ssa to rssa *)
+ | FFI of 'a CFunction.t (* ssa to rssa *)
  | FFI_Symbol of {name: string,
-		  ty: RepType.t} (* codegen *)
+		  ty: 'a} (* codegen *)
  | GC_collect (* ssa to rssa *)
  | GC_pack (* ssa to rssa *)
  | GC_unpack (* ssa to rssa *)
@@ -115,14 +115,14 @@
  | MLton_serialize (* unused *)
  | MLton_size (* ssa to rssa *)
  | MLton_touch (* backend *)
- | Pointer_getInt of IntSize.t (* backend *)
- | Pointer_getPointer (* backend *)
- | Pointer_getReal of RealSize.t (* backend *)
- | Pointer_getWord of WordSize.t (* backend *)
- | Pointer_setInt of IntSize.t (* backend *)
- | Pointer_setPointer (* backend *)
- | Pointer_setReal of RealSize.t (* backend *)
- | Pointer_setWord of WordSize.t (* 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 *)
  | Real_Math_acos of RealSize.t (* codegen *)
  | Real_Math_asin of RealSize.t (* codegen *)
  | Real_Math_atan of RealSize.t (* codegen *)
@@ -168,7 +168,7 @@
   *)
  | Thread_switchTo (* ssa to rssa *)
  | Vector_length (* ssa to rssa *)
- | Vector_sub (* backend *)
+ | Vector_sub (* ssa to rssa *)
  | Weak_canGet (* ssa to rssa *)
  | Weak_get (* ssa to rssa *)
  | Weak_new (* ssa to rssa *)
@@ -208,11 +208,11 @@
  | World_save (* ssa to rssa *)
 
 fun name p = p
-   
+
 (* The values of these strings are important since they are referred to
  * in the basis library code.  See basis-library/misc/primitive.sml.
  *)
-fun toString (n: t): string =
+fun toString (n: 'a t): string =
    let
       fun int (s: IntSize.t, str: string): string =
 	 concat ["Int", IntSize.toString s, "_", str]
@@ -389,9 +389,9 @@
        | World_save => "World_save"
    end
 
-val layout = Layout.str o toString
+fun layout p = Layout.str (toString p)
    
-val equals: t * t -> bool =
+val equals: 'a t * 'a t -> bool =
    fn (Array_array, Array_array) => true
     | (Array_array0Const, Array_array0Const) => true
     | (Array_length, Array_length) => true
@@ -555,7 +555,164 @@
     | (World_save, World_save) => true
     | _ => false
 
-val allocTooLarge = FFI CFunction.allocTooLarge
+val map: 'a t * ('a -> 'b) -> 'b t =
+   fn (p, f) =>
+   case p of
+      Array_array => Array_array
+    | Array_array0Const => Array_array0Const
+    | Array_length => Array_length
+    | 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
+    | Exn_setExtendExtra => Exn_setExtendExtra
+    | Exn_setInitExtra => Exn_setInitExtra
+    | Exn_setTopLevelHandler => Exn_setTopLevelHandler
+    | FFI func => FFI (CFunction.map (func, f))
+    | FFI_Symbol {name, ty} => FFI_Symbol {name = name, ty = f ty}
+    | 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_equal z => Int_equal z
+    | Int_ge z => Int_ge z
+    | Int_gt z => Int_gt z
+    | Int_le z => Int_le 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
+    | IntInf_compare => IntInf_compare
+    | IntInf_equal => IntInf_equal
+    | IntInf_gcd => IntInf_gcd
+    | IntInf_lshift => IntInf_lshift
+    | IntInf_mul => IntInf_mul
+    | IntInf_neg => IntInf_neg
+    | IntInf_notb => IntInf_notb
+    | IntInf_orb => IntInf_orb
+    | IntInf_quot => IntInf_quot
+    | IntInf_rem => IntInf_rem
+    | IntInf_sub => IntInf_sub
+    | IntInf_toString => IntInf_toString
+    | IntInf_toVector => IntInf_toVector
+    | IntInf_toWord => IntInf_toWord
+    | IntInf_xorb => IntInf_xorb
+    | MLton_bogus => MLton_bogus
+    | MLton_bug => MLton_bug
+    | MLton_deserialize => MLton_deserialize
+    | MLton_eq => MLton_eq
+    | MLton_equal => MLton_equal
+    | MLton_halt => MLton_halt
+    | MLton_handlesSignals => MLton_handlesSignals
+    | MLton_installSignalHandler => MLton_installSignalHandler
+    | 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
+    | Real_Math_acos z => Real_Math_acos z
+    | Real_Math_asin z => Real_Math_asin z
+    | Real_Math_atan z => Real_Math_atan z
+    | Real_Math_atan2 z => Real_Math_atan2 z
+    | Real_Math_cos z => Real_Math_cos z
+    | Real_Math_exp z => Real_Math_exp z
+    | Real_Math_ln z => Real_Math_ln z
+    | Real_Math_log10 z => Real_Math_log10 z
+    | Real_Math_sin z => Real_Math_sin z
+    | Real_Math_sqrt z => Real_Math_sqrt z
+    | Real_Math_tan z => Real_Math_tan z
+    | Real_abs z => Real_abs z
+    | Real_add z => Real_add z
+    | Real_div z => Real_div z
+    | Real_equal z => Real_equal z
+    | Real_ge z => Real_ge z
+    | Real_gt z => Real_gt z
+    | Real_ldexp z => Real_ldexp z
+    | Real_le z => Real_le z
+    | Real_lt z => Real_lt z
+    | Real_mul z => Real_mul z
+    | Real_muladd z => Real_muladd z
+    | Real_mulsub z => Real_mulsub z
+    | Real_neg z => Real_neg z
+    | 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
+    | Ref_assign => Ref_assign
+    | Ref_deref => Ref_deref
+    | Ref_ref => Ref_ref
+    | String_toWord8Vector => String_toWord8Vector
+    | Thread_atomicBegin => Thread_atomicBegin
+    | Thread_atomicEnd => Thread_atomicEnd
+    | Thread_canHandle => Thread_canHandle
+    | Thread_copy => Thread_copy
+    | Thread_copyCurrent => Thread_copyCurrent
+    | Thread_returnToC => Thread_returnToC
+    | Thread_switchTo => Thread_switchTo
+    | Vector_length => Vector_length
+    | Vector_sub => Vector_sub
+    | Weak_canGet => Weak_canGet
+    | Weak_get => Weak_get
+    | Weak_new => Weak_new
+    | 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_notb z => Word_notb z
+    | Word_orb z => Word_orb z
+    | Word_rol z => Word_rol 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_toIntInf => Word_toIntInf
+    | Word_toIntX z => Word_toIntX 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
+    | Word8Vector_toString => Word8Vector_toString
+    | World_save => World_save
+
+val cast: 'a t -> 'b t = fn p => map (p, fn _ => Error.bug "Prim.cast")
+
 val array = Array_array
 val assign = Ref_assign
 val bogus = MLton_bogus
@@ -637,11 +794,13 @@
 
 val mayRaise = mayOverflow
 
-val kind: t -> Kind.t =
+val kind: 'a t -> Kind.t =
+   fn p =>
    let
       datatype z = datatype Kind.t
    in
-      fn Array_array => Moveable
+      case p of
+	 Array_array => Moveable
        | Array_array0Const => Moveable
        | Array_length => Functional
        | Array_sub => DependsOnState
@@ -798,10 +957,8 @@
 local
    fun make k p = k = kind p
 in
-   val isFunctional = make Kind.Functional
-   val isFunctional =
-      Trace.trace ("isFunctional", layout, Bool.layout) isFunctional
-   val maySideEffect = make Kind.SideEffect
+   fun isFunctional p = Kind.Functional = kind p
+   fun maySideEffect p = Kind.SideEffect = kind p
 end
 
 local
@@ -875,7 +1032,7 @@
        (Word_sub s),
        (Word_xorb s)]
 in
-   val all: t list =
+   val all: unit t list =
       [Array_array,
        Array_array0Const,
        Array_length,
@@ -921,6 +1078,8 @@
        MLton_serialize,
        MLton_size,
        MLton_touch,
+       Pointer_getPointer,
+       Pointer_setPointer,
        Ref_assign,
        Ref_deref,
        Ref_ref,
@@ -972,7 +1131,6 @@
 	     List.concatMap (all, fn s => [get s, set s])
        in
 	  List.concat [doit (IntSize.prims, Pointer_getInt, Pointer_setInt),
-		       [Pointer_getPointer, Pointer_setPointer],
 		       doit (RealSize.all, Pointer_getReal, Pointer_setReal),
 		       doit (WordSize.prims, Pointer_getWord, Pointer_setWord)]
        end
@@ -980,7 +1138,7 @@
 
 local
    val table: {hash: word,
-	       prim: t,
+	       prim: unit t,
 	       string: string} HashSet.t =
       HashSet.new {hash = #hash}
    val () =
@@ -998,25 +1156,23 @@
 		       ()
 		    end)
 in
-   val fromString: string -> t =
+   val fromString: string -> 'a t =
       fn name =>
-      #prim
-      (HashSet.lookupOrInsert
-       (table, String.hash name,
-	fn {string, ...} => name = string,
-	fn () => Error.bug (concat ["unknown primitive: ", name])))
+      cast
+      (#prim
+       (HashSet.lookupOrInsert
+	(table, String.hash name,
+	 fn {string, ...} => name = string,
+	 fn () => Error.bug (concat ["unknown primitive: ", name]))))
 end
 
-val fromString =
-   Trace.trace ("Prim.fromString", String.layout, layout) fromString
-
 fun 'a extractTargs {args: 'a vector,
 		     deArray: 'a -> 'a,
 		     deArrow: 'a -> 'a * 'a,
 		     deRef: 'a -> 'a,
 		     deVector: 'a -> 'a,
 		     deWeak: 'a -> 'a,
-		     prim: t,
+		     prim: 'a t,
 		     result: 'a} =
    let
       val one = Vector.new1
@@ -1076,22 +1232,27 @@
 
 structure ApplyResult =
    struct
-      type prim = t
-      datatype 'a t =
-	 Apply of prim * 'a list
+      type 'a prim = 'a t
+
+      datatype ('a, 'b) t =
+	 Apply of 'a prim * 'b list
        | Bool of bool
        | Const of Const.t
        | Overflow
        | Unknown
-       | Var of 'a
+       | Var of 'b
 
       val truee = Bool true
       val falsee = Bool false
 
       val layoutPrim = layout
-      fun layout layoutX =
-	 let open Layout
-	 in fn Apply (p, args) => seq [layoutPrim p, List.layout layoutX args]
+
+      fun layout layoutX ar =
+	 let
+	    open Layout
+	 in
+	    case ar of
+	       Apply (p, args) => seq [layoutPrim p, List.layout layoutX args]
 	     | Bool b => Bool.layout b
 	     | Const c => Const.layout c
 	     | Overflow => str "Overflow"
@@ -1127,7 +1288,9 @@
  * A x = B y --> false
  *)
    
-fun 'a apply (p, args, varEquals) =
+fun ('a, 'b) apply (p: 'a t,
+		    args: 'b ApplyArg.t list,
+		    varEquals: 'b * 'b -> bool): ('a, 'b) ApplyResult.t =
    let
       datatype z = datatype t
       datatype z = datatype Const.t
@@ -1135,7 +1298,7 @@
       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 ApplyResult.t =
+      fun word (w: WordX.t): ('a, 'b) ApplyResult.t =
 	 ApplyResult.Const (Const.word w)
       val word8Vector = ApplyResult.Const o Const.word8Vector
       val t = ApplyResult.truee
@@ -1238,9 +1401,9 @@
       fun someVars () =
 	 let
 	    datatype z = datatype ApplyResult.t
-	    fun add (x: 'a, i: IntX.t): 'a 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: 'a, i: IntX.t, s: IntSize.t, neg) =
+	    fun mul (x: 'b, i: IntX.t, s: IntSize.t, neg) =
 	       (case IntX.toInt i of
 		   0 => int (IntX.zero s)
 		 | 1 => Var x
@@ -1587,7 +1750,9 @@
       else someVars ()
    end
 
-fun layoutApp (p: t, args: 'a vector, layoutArg: 'a -> Layout.t): Layout.t =
+fun ('a, 'b) layoutApp (p: 'a t,
+			args: 'b vector,
+			layoutArg: 'b -> Layout.t): Layout.t =
    let
       fun arg i = layoutArg (Vector.sub (args, i))
       open Layout
@@ -1657,178 +1822,6 @@
        | Word_xorb _ => two "^"
        | _ => seq [layout p, str " ", Vector.layout layoutArg args]
    end
-
-structure Type = RepType
-
-fun typeCheck (p: t, ts: Type.t vector): Type.t option =
-   let
-      fun nullary res =
-	 if 0 = Vector.length ts
-	    then res
-	 else NONE
-      fun unary (t0, res) =
-	 if 1 = Vector.length ts
-	    andalso Type.isSubtype (Vector.sub (ts, 0), t0)
-	    then SOME res
-	 else NONE
-      fun two f =
-	 if 2 = Vector.length ts
-	    then f (Vector.sub (ts, 0), Vector.sub (ts, 1))
-	 else NONE
-      fun twoWord f =
-	 two (fn (t, t') =>
-	      if Bits.equals (Type.width t, Type.width t')
-		 then SOME (f (t, t'))
-	      else NONE)
-      fun binary (t0, t1, res) =
-	 two (fn (t0', t1') =>
-	      if Type.isSubtype (Vector.sub (ts, 0), t0)
-		 andalso Type.isSubtype (Vector.sub (ts, 1), t1)
-		 then SOME res
-	      else NONE)
-      fun ternary (t0, t1, t2, res) =
-	 if 3 = Vector.length ts
-	    andalso Type.isSubtype (Vector.sub (ts, 0), t0)
-	    andalso Type.isSubtype (Vector.sub (ts, 1), t1)
-	    andalso Type.isSubtype (Vector.sub (ts, 2), t2)
-	    then SOME res
-	 else NONE
-      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, Type.bool) end
-      in
-	 val intCompare = make int
-	 val realCompare = make real
-	 val wordCompare = make word
-      end
-      fun wordShift s = binary (word s, defaultWord, word s)
-      fun wordShift' f = two (fn (t, t') => SOME (f (t, t')))
-      fun real3 s =
-	 let
-	    val t = real s
-	 in
-	    ternary (t, t, t, t)
-	 end
-   in
-      case p of
-	 FFI f =>
-	    let
-	       val CFunction.T {args, return, ...} = f
-	    in
-	       if Vector.equals (ts, args, Type.isSubtype)
-		  then SOME return
-	       else NONE
-	    end
-       | FFI_Symbol {ty, ...} => nullary (SOME 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) =>
-		 if Type.isSubtype (t1, t2) orelse Type.isSubtype (t2, t1)
-		    then SOME Type.bool
-		 else NONE)
-       | Real_Math_acos s => realUnary s
-       | Real_Math_asin s => realUnary s
-       | Real_Math_atan s => realUnary s
-       | Real_Math_atan2 s => realBinary s
-       | Real_Math_cos s => realUnary s
-       | Real_Math_exp s => realUnary s
-       | Real_Math_ln s => realUnary s
-       | Real_Math_log10 s => realUnary s
-       | Real_Math_sin s => realUnary s
-       | Real_Math_sqrt s => realUnary s
-       | Real_Math_tan s => realUnary s
-       | Real_abs s => realUnary s
-       | Real_add s => realBinary s
-       | Real_div s => realBinary s
-       | 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_le s => realCompare s
-       | Real_lt s => realCompare s
-       | Real_mul s => realBinary s
-       | Real_muladd s => real3 s
-       | Real_mulsub s => real3 s
-       | Real_neg s => realUnary s
-       | 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')
-       | Thread_returnToC => nullary (SOME Type.unit)
-       | Word_add s => twoWord Type.add
-       | Word_addCheck s => wordBinary s
-       | Word_andb s => two Type.andb
-       | 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_lshift s => wordShift' Type.lshift
-       | Word_lt s => wordCompare s
-       | Word_mod s => wordBinary s
-       | Word_mul s => twoWord Type.mul
-       | Word_mulCheck s => wordBinary s
-       | Word_neg s => wordUnary s
-       | Word_notb s => wordUnary s
-       | Word_orb s => two Type.orb
-       | Word_rol s => wordShift s
-       | Word_ror s => wordShift s
-       | Word_rshift s => wordShift' Type.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') => unary (word s, word s')
-       | Word_toWordX (s, s') => unary (word s, word s')
-       | Word_xorb s => wordBinary s
-       | _ => Error.bug (concat ["strange primitive to Prim.typeCheck: ",
-				 toString p])
-   end
-
-val typeCheck =
-   Trace.trace2 ("Prim.typeCheck", layout, Vector.layout Type.layout,
-		 Option.layout Type.layout)
-   typeCheck
 
 structure Name =
    struct



1.58      +73 -76    mlton/mlton/atoms/prim.sig

Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- prim.sig	4 Apr 2004 06:50:14 -0000	1.57
+++ prim.sig	12 Apr 2004 17:52:48 -0000	1.58
@@ -13,13 +13,10 @@
       structure Const: CONST
       structure IntSize: INT_SIZE
       structure RealSize: REAL_SIZE
-      structure RepType: REP_TYPE
       structure WordSize: WORD_SIZE
-      sharing CType = RepType.CType
-      sharing IntSize = Const.IntX.IntSize = RepType.IntSize
-      sharing RealSize = Const.RealX.RealSize = RepType.RealSize
-      sharing RepType = CFunction.RepType
-      sharing WordSize = Const.WordX.WordSize = RepType.WordSize
+      sharing IntSize = Const.IntX.IntSize
+      sharing RealSize = Const.RealX.RealSize
+      sharing WordSize = Const.WordX.WordSize
    end
 
 signature PRIM = 
@@ -28,7 +25,7 @@
 
       structure Name:
 	 sig
-	    datatype t =
+	    datatype 'a t =
 	       Array_array (* backend *)
 	     | Array_array0Const (* constant propagation *)
 	     | Array_length (* ssa to rssa *)
@@ -42,9 +39,9 @@
 	     | Exn_setExtendExtra (* implement exceptions *)
 	     | Exn_setInitExtra (* implement exceptions *)
 	     | Exn_setTopLevelHandler (* implement exceptions *)
-	     | FFI of CFunction.t (* ssa to rssa *)
+	     | FFI of 'a CFunction.t (* ssa to rssa *)
 	     | FFI_Symbol of {name: string,
-			      ty: RepType.t} (* codegen *)
+			      ty: 'a} (* codegen *)
 	     | GC_collect (* ssa to rssa *)
 	     | GC_pack (* ssa to rssa *)
 	     | GC_unpack (* ssa to rssa *)
@@ -202,12 +199,10 @@
 	     | Word8Vector_toString (* type inference *)
 	     | World_save (* ssa to rssa *)
 
-	    val layout: t -> Layout.t
-	    val toString: t -> string
+	    val layout: 'a t -> Layout.t
+	    val toString: 'a t -> string
 	 end
 
-      type t
-
       structure ApplyArg:
 	 sig
 	    datatype 'a t =
@@ -219,52 +214,54 @@
 	 end
       structure ApplyResult:
 	 sig
-	    type prim
-	    datatype 'a t =
-	       Apply of prim * 'a list
+	    type 'a prim
+	    datatype ('a, 'b) t =
+	       Apply of 'a prim * 'b list
 	     | Bool of bool
 	     | Const of Const.t
 	     | Overflow
 	     | Unknown
-	     | Var of 'a
+	     | Var of 'b
 
-	    val layout: ('a -> Layout.t) -> 'a t -> Layout.t
-	 end where type prim = t
-
-      val allocTooLarge: t
-      val apply: t * 'a ApplyArg.t list * ('a * 'a -> bool) -> 'a ApplyResult.t
-      val array: t
-      val assign: t
-      val bogus: t
-      val bug: t
-      val deref: t
-      val deserialize: t
-      val eq: t    (* pointer equality *)
-      val equal: t (* polymorphic equality *)
-      val equals: t * t -> bool
+	    val layout: ('b -> Layout.t) -> ('a, 'b) t -> Layout.t
+	 end
+      
+      type 'a t
+      sharing type t = ApplyResult.prim
+      val apply:
+	 'a t * 'b ApplyArg.t list * ('b * 'b -> bool) -> ('a, 'b) ApplyResult.t
+      val array: 'a t
+      val assign: 'a t
+      val bogus: 'a t
+      val bug: 'a t
+      val deref: 'a t
+      val deserialize: 'a t
+      val eq: 'a t    (* pointer equality *)
+      val equal: 'a t (* polymorphic equality *)
+      val equals: 'a t * 'a t -> bool
       val extractTargs: {args: 'a vector,
 			 deArray: 'a -> 'a,
 			 deArrow: 'a -> 'a * 'a,
 			 deRef: 'a -> 'a,
 			 deVector: 'a -> 'a,
 			 deWeak: 'a -> 'a,
-			 prim: t,
+			 prim: 'a t,
 			 result: 'a} -> 'a vector
-      val ffi: CFunction.t -> t
-      val ffiSymbol: {name: string, ty: RepType.t} -> t
-      val fromString: string -> t
-      val gcCollect: t
-      val intInfEqual: t
-      val intAdd: IntSize.t -> t
-      val intAddCheck: IntSize.t -> t
-      val intEqual: IntSize.t -> t
-      val intMul: IntSize.t -> t
-      val intMulCheck: IntSize.t -> t
-      val intSub: IntSize.t -> t
-      val intSubCheck: IntSize.t -> t
-      val intToInt: IntSize.t * IntSize.t -> t
-      val intToWord: IntSize.t * WordSize.t -> t
-      val isCommutative: t -> bool
+      val ffi: 'a CFunction.t -> 'a t
+      val ffiSymbol: {name: string, ty: 'a} -> 'a t
+      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 intToInt: IntSize.t * IntSize.t -> 'a t
+      val intToWord: IntSize.t * WordSize.t -> 'a t
+      val isCommutative: 'a t -> bool
       (*
        * isFunctional p = true iff p always returns same result when given
        *   same args and has no side effects.
@@ -272,37 +269,37 @@
        * examples: Array_length, MLton_equal, Int_add
        * not examples: Array_array, Array_sub, Ref_deref, Ref_ref
        *)
-      val isFunctional: t -> bool
-      val layout: t -> Layout.t
-      val layoutApp: t * 'a vector * ('a -> Layout.t) -> Layout.t
+      val isFunctional: 'a t -> bool
+      val layout: 'a t -> Layout.t
+      val layoutApp: 'a t * 'b vector * ('b -> Layout.t) -> Layout.t
+      val map: 'a t * ('a -> 'b) -> 'b t
       (* Int_addCheck, Int_mulCheck, Int_subCheck *)
-      val mayOverflow: t -> bool
-      val mayRaise: t -> bool
+      val mayOverflow: 'a t -> bool
+      val mayRaise: 'a t -> bool
       (* examples: Array_update, Ref_assign
        * not examples: Array_array, Array_sub, Ref_deref, Ref_ref
        *)
-      val maySideEffect: t -> bool
-      val name: t -> Name.t
-      val reff: t
-      val serialize: t
-      val toString: t -> string
-      val typeCheck: t * RepType.t vector -> RepType.t option
-      val vectorLength: t
-      val vectorSub: t
-      val wordAdd: WordSize.t -> t
-      val wordAddCheck: WordSize.t -> t
-      val wordAndb: WordSize.t -> t
-      val wordEqual: WordSize.t -> t
-      val wordGe: WordSize.t -> t
-      val wordGt: WordSize.t -> t
-      val wordLe: WordSize.t -> t
-      val wordLt: WordSize.t -> t
-      val wordLshift: WordSize.t -> t
-      val wordMul: WordSize.t -> t
-      val wordMulCheck: WordSize.t -> t
-      val wordRshift: WordSize.t -> t
-      val wordSub: WordSize.t -> t
-      val wordToInt: WordSize.t * IntSize.t -> t
-      val wordToIntX: WordSize.t * IntSize.t -> t
-      val wordToWord: WordSize.t * WordSize.t -> t
+      val maySideEffect: 'a t -> bool
+      val name: 'a t -> 'a Name.t
+      val reff: 'a t
+      val serialize: 'a t
+      val toString: 'a t -> string
+      val vectorLength: 'a t
+      val vectorSub: 'a t
+      val wordAdd: WordSize.t -> 'a t
+      val wordAddCheck: WordSize.t -> 'a t
+      val wordAndb: 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 wordLshift: WordSize.t -> 'a t
+      val wordMul: WordSize.t -> 'a t
+      val wordMulCheck: WordSize.t -> 'a t
+      val wordRshift: WordSize.t -> 'a t
+      val wordSub: WordSize.t -> 'a t
+      val wordToInt: WordSize.t * IntSize.t -> 'a t
+      val wordToIntX: WordSize.t * IntSize.t -> 'a t
+      val wordToWord: WordSize.t * WordSize.t -> 'a t
    end



1.2       +244 -1    mlton/mlton/atoms/rep-type.fun

Index: rep-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/rep-type.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- rep-type.fun	4 Apr 2004 06:50:14 -0000	1.1
+++ rep-type.fun	12 Apr 2004 17:52:48 -0000	1.2
@@ -10,6 +10,8 @@
 
 open S
 
+structure CFunction = Prim.CFunction
+
 type int = Int.t
 
 structure Type =
@@ -761,6 +763,20 @@
 	     (1 + 2 * Int.toIntInf (PointerTycon.index p),
 	      WordSize.default))
 
+fun arrayOffsetIsOk {base: t, index: t, pointerTy, result: t}: bool =
+   isSubtype (index, defaultInt)
+   andalso
+   case dest base of
+      Pointer p =>
+	 (case pointerTy p of
+	     ObjectType.Array ty =>
+		isSubtype (ty, result)
+		orelse
+		(* Get a word from a word8 array.*)
+		(equals (result, defaultWord) andalso equals (ty, word8))
+	   | _ => false)
+    | _ => isCPointer base
+   
 fun offset (t: t, {offset, pointerTy, width}): t option =
    let
       fun frag t =
@@ -776,7 +792,7 @@
 		  (case pointerTy p of
 		      ObjectType.Array _ =>
 			 if Bytes.equals (offset, Runtime.arrayLengthOffset)
-			    then SOME Type.defaultInt
+			    then SOME defaultInt
 			 else NONE
 		    | ObjectType.Normal t => SOME (frag t)
 		    | _ => NONE)
@@ -803,6 +819,13 @@
     Option.layout layout)
    offset
 
+fun offsetIsOk {base, offset = off, pointerTy, result} =
+   case offset (base, {offset = off,
+		       pointerTy = pointerTy,
+		       width = width result}) of
+      NONE => false
+    | SOME t => isSubtype (t, result)
+
 structure GCField = Runtime.GCField
    
 fun ofGCField (f: GCField.t): t =
@@ -825,5 +848,225 @@
    end
 
 fun castIsOk _ = true
+
+fun checkPrimApp {args: t vector, prim: t Prim.t, result: t option}: bool =
+   let
+      fun done t =
+	 case result of
+	    NONE => true
+	  | SOME t' => isSubtype (t, t')
+      fun nullary res =
+	 0 = Vector.length args
+	 andalso done res
+      fun arg i = Vector.sub (args, i)
+      fun unary (t0, res) =
+	 1 = Vector.length args
+	 andalso isSubtype (arg 0, t0)
+	 andalso done res
+      fun two f = 2 = Vector.length args andalso f (arg 0, arg 1)
+      fun twoOpt f =
+	 two (fn z =>
+	      case f z of
+		 NONE => false
+	       | SOME t => done t)
+      fun twoWord f =
+	 two (fn (t, t') =>
+	      Bits.equals (width t, width t') andalso done (f (t, t')))
+      fun binary (t0, t1, res) =
+	 two (fn (t0', t1') =>
+	      isSubtype (arg 0, t0)
+	      andalso isSubtype (arg 1, t1)
+	      andalso done res)
+      fun ternary (t0, t1, t2, res) =
+	 3 = Vector.length args
+	 andalso isSubtype (arg 0, t0)
+	 andalso isSubtype (arg 1, t1)
+	 andalso isSubtype (arg 2, t2)
+	 andalso done res
+      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
+      fun wordShift s = binary (word s, defaultWord, word s)
+      fun wordShift' f = two (fn (t, t') => done (f (t, t')))
+      fun real3 s =
+	 let
+	    val t = real s
+	 in
+	    ternary (t, t, t, t)
+	 end
+      datatype z = datatype Prim.Name.t
+   in
+      case Prim.name prim of
+	 FFI f =>
+	    let
+	       val CFunction.T {args = expects, return, ...} = f
+	    in
+	       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))
+		 andalso done bool)
+       | Real_Math_acos s => realUnary s
+       | Real_Math_asin s => realUnary s
+       | Real_Math_atan s => realUnary s
+       | Real_Math_atan2 s => realBinary s
+       | Real_Math_cos s => realUnary s
+       | Real_Math_exp s => realUnary s
+       | Real_Math_ln s => realUnary s
+       | Real_Math_log10 s => realUnary s
+       | Real_Math_sin s => realUnary s
+       | Real_Math_sqrt s => realUnary s
+       | Real_Math_tan s => realUnary s
+       | Real_abs s => realUnary s
+       | Real_add s => realBinary s
+       | Real_div s => realBinary s
+       | 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_le s => realCompare s
+       | Real_lt s => realCompare s
+       | Real_mul s => realBinary s
+       | Real_muladd s => real3 s
+       | Real_mulsub s => real3 s
+       | Real_neg s => realUnary s
+       | 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')
+       | Thread_returnToC => nullary unit
+       | Word_add s => twoWord add
+       | Word_addCheck s => wordBinary s
+       | Word_andb s => twoOpt andb
+       | 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_lshift s => wordShift' lshift
+       | Word_lt s => wordCompare s
+       | Word_mod s => wordBinary s
+       | Word_mul s => twoWord mul
+       | Word_mulCheck s => wordBinary s
+       | Word_neg s => wordUnary s
+       | Word_notb s => wordUnary s
+       | Word_orb s => twoOpt orb
+       | Word_rol s => wordShift s
+       | Word_ror s => wordShift s
+       | Word_rshift s => wordShift' 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') => unary (word s, word s')
+       | Word_toWordX (s, s') => unary (word s, word s')
+       | Word_xorb s => wordBinary s
+       | _ => Error.bug (concat ["strange primitive to Prim.typeCheck: ",
+				 Prim.toString prim])
+   end
+
+val checkPrimApp =
+   Trace.trace ("RepType.checkPrimApp",
+		fn {args, prim, result} =>
+		Layout.record [("args", Vector.layout layout args),
+			       ("prim", Prim.layout prim),
+			       ("result", Option.layout layout result)],
+		Bool.layout)
+   checkPrimApp
+
+structure BuiltInCFunction =
+   struct
+      open CFunction
+
+      type t = Type.t CFunction.t
+
+      datatype z = datatype Convention.t
+	 
+      val bug = vanilla {args = Vector.new1 string,
+			 name = "MLton_bug",
+			 return = unit}
+
+      local
+	 open Type
+      in
+	 val Int32 = int (IntSize.I (Bits.fromInt 32))
+	 val Word32 = word (Bits.fromInt 32)
+	 val bool = bool
+	 val cPointer = cPointer
+	 val gcState = gcState
+	 val string = word8Vector
+	 val unit = unit
+      end
+   
+      local
+	 fun make b =
+	    T {args = let
+			 open Type
+		      in
+			 Vector.new5 (gcState, Word32, bool, cPointer (), Int32)
+		      end,
+		   bytesNeeded = NONE,
+		   convention = Cdecl,
+		   ensuresBytesFree = true,
+		   mayGC = true,
+		   maySwitchThreads = b,
+		   modifiesFrontier = true,
+		   modifiesStackTop = true,
+		   name = "GC_gc",
+		   return = unit}
+	 val t = make true
+	 val f = make false
+      in
+	 fun gc {maySwitchThreads = b} = if b then t else f
+      end
+   end
 
 end



1.2       +23 -5     mlton/mlton/atoms/rep-type.sig

Index: rep-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/rep-type.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- rep-type.sig	4 Apr 2004 06:50:14 -0000	1.1
+++ rep-type.sig	12 Apr 2004 17:52:55 -0000	1.2
@@ -7,23 +7,27 @@
 
 signature REP_TYPE_STRUCTS =
    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
       structure RealSize: REAL_SIZE
       structure Runtime: RUNTIME
       structure WordSize: WORD_SIZE
       structure WordX: WORD_X
-      sharing IntSize = IntX.IntSize
-      sharing WordSize = WordX.WordSize
+      sharing CFunction = Prim.CFunction
+      sharing IntSize = IntX.IntSize = Prim.IntSize
+      sharing RealSize = Prim.RealSize
+      sharing WordSize = Prim.WordSize = WordX.WordSize
    end
 
 signature REP_TYPE =
    sig
       include REP_TYPE_STRUCTS
-	 
+
       structure ObjectType: OBJECT_TYPE
       (*
        * - Junk is used for padding.  You can stick any value in, but you
@@ -55,12 +59,19 @@
       val address: t -> t
       val align: t * Bytes.t -> Bytes.t
       val andb: t * t -> t option
+      val arrayOffsetIsOk: {base: t,
+			    index: t,
+			    pointerTy: PointerTycon.t -> ObjectType.t,
+			    result: t} -> bool
       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,
+			 prim: t Prim.t,
+			 result: t option} -> bool
       val char: t
       val cPointer: unit -> t
       val constant: WordX.t -> t
@@ -88,9 +99,10 @@
       val mul: t * t -> t
       val name: t -> string (* simple one letter abbreviation *)
       val ofGCField: Runtime.GCField.t -> t
-      val offset: t * {offset: Bytes.t,
+      val offsetIsOk: {base: t,
+		       offset: Bytes.t,
 		       pointerTy: PointerTycon.t -> ObjectType.t,
-		       width: Bits.t} -> t option
+		       result: t} -> bool
       val orb: t * t -> t option
       val pointer: PointerTycon.t -> t
       val pointerHeader: PointerTycon.t -> t
@@ -108,4 +120,10 @@
       val word8: t
       val wordVector: t
       val word8Vector: t
+
+      structure BuiltInCFunction:
+	 sig
+	    val bug: t CFunction.t
+	    val gc: {maySwitchThreads: bool} -> t CFunction.t
+	 end
    end



1.21      +2 -2      mlton/mlton/atoms/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- sources.cm	4 Apr 2004 06:50:14 -0000	1.20
+++ sources.cm	12 Apr 2004 17:52:56 -0000	1.21
@@ -66,14 +66,14 @@
 pointer-tycon.fun
 object-type.sig
 label.sig
-rep-type.sig
-rep-type.fun
 c-function.sig
 c-function.fun
 const.sig
 const.fun
 prim.sig
 prim.fun
+rep-type.sig
+rep-type.fun
 ffi.sig
 ffi.fun
 func.sig



1.12      +0 -1      mlton/mlton/atoms/type-ops.fun

Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- type-ops.fun	4 Apr 2004 06:50:14 -0000	1.11
+++ type-ops.fun	12 Apr 2004 17:52:56 -0000	1.12
@@ -29,7 +29,6 @@
    val exn = nullary Tycon.exn
    val int = IntSize.memoize (fn s => nullary (Tycon.int s))
    val intInf = nullary Tycon.intInf
-   val pointer = nullary Tycon.pointer
    val preThread = nullary Tycon.preThread
    val real = RealSize.memoize (fn s => nullary (Tycon.real s))
    val thread = nullary Tycon.thread



1.9       +0 -1      mlton/mlton/atoms/type-ops.sig

Index: type-ops.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- type-ops.sig	9 Oct 2003 18:17:31 -0000	1.8
+++ type-ops.sig	12 Apr 2004 17:52:56 -0000	1.9
@@ -60,7 +60,6 @@
       val isTuple: t -> bool
       val list: t -> t
       val nth: t * int -> t
-      val pointer: t
       val preThread: t
       val real: realSize -> t
       val reff: t -> t



1.65      +1 -1      mlton/mlton/backend/backend.fun

Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- backend.fun	4 Apr 2004 06:50:16 -0000	1.64
+++ backend.fun	12 Apr 2004 17:52:56 -0000	1.65
@@ -542,7 +542,7 @@
 	 {args = (Vector.new1
 		  (globalString "backend thought control shouldn't reach here")),
 	  frameInfo = NONE,
-	  func = CFunction.bug,
+	  func = Type.BuiltInCFunction.bug,
 	  return = NONE}
       val {get = labelInfo: Label.t -> {args: (Var.t * Type.t) vector},
 	   set = setLabelInfo, ...} =



1.48      +5 -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.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- limit-check.fun	4 Apr 2004 06:50:16 -0000	1.47
+++ limit-check.fun	12 Apr 2004 17:52:57 -0000	1.48
@@ -66,6 +66,11 @@
 open S
 open Rssa
 
+structure CFunction =
+   struct
+      open CFunction Type.BuiltInCFunction
+   end
+
 structure Statement =
    struct
       open Statement



1.60      +20 -34    mlton/mlton/backend/machine.fun

Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- machine.fun	4 Apr 2004 06:50:16 -0000	1.59
+++ machine.fun	12 Apr 2004 17:52:57 -0000	1.60
@@ -304,7 +304,7 @@
 			     value: Operand.t} vector}
        | PrimApp of {args: Operand.t vector,
 		     dst: Operand.t option,
-		     prim: Prim.t}
+		     prim: Type.t Prim.t}
        | ProfileLabel of ProfileLabel.t
 
       val layout =
@@ -398,11 +398,11 @@
 	 Arith of {args: Operand.t vector,
 		   dst: Operand.t,
 		   overflow: Label.t,
-		   prim: Prim.t,
+		   prim: Type.t Prim.t,
 		   success: Label.t}
        | CCall of {args: Operand.t vector,
 		   frameInfo: FrameInfo.t option,
-		   func: CFunction.t,
+		   func: Type.t CFunction.t,
 		   return: Label.t option}
        | Call of {label: Label.t,
 		  live: Operand.t vector,
@@ -431,7 +431,7 @@
 		       record
 		       [("args", Vector.layout Operand.layout args),
 			("frameInfo", Option.layout FrameInfo.layout frameInfo),
-			("func", CFunction.layout func),
+			("func", CFunction.layout (func, Type.layout)),
 			("return", Option.layout Label.layout return)]]
 	     | Call {label, live, return} => 
 		  seq [str "Call ", 
@@ -473,7 +473,7 @@
 		  frameInfo: FrameInfo.t}
        | CReturn of {dst: Operand.t option,
 		     frameInfo: FrameInfo.t option,
-		     func: CFunction.t}
+		     func: Type.t CFunction.t}
        | Func
        | Handler of {frameInfo: FrameInfo.t,
 		     handles: Operand.t vector}
@@ -493,7 +493,7 @@
 		       record
 		       [("dst", Option.layout Operand.layout dst),
 			("frameInfo", Option.layout FrameInfo.layout frameInfo),
-			("func", CFunction.layout func)]]
+			("func", CFunction.layout (func, Type.layout))]]
 	     | Func => str "Func"
 	     | Handler {frameInfo, handles} =>
 		  seq [str "Handler ",
@@ -921,10 +921,13 @@
 		  datatype z = datatype Operand.t
 		  fun ok () =
 		     case x of
-			ArrayOffset (z as {base, index, ...}) =>
+			ArrayOffset {base, index, ty} =>
 			   (checkOperand (base, alloc)
 			    ; checkOperand (index, alloc)
-			    ; arrayOffsetIsOk z)
+			     ; Type.arrayOffsetIsOk {base = Operand.ty base,
+						     index = Operand.ty index,
+						     pointerTy = tyconTy,
+						     result = ty})
 		      | Cast (z, t) =>
 			   (checkOperand (z, alloc)
 			    ; (Type.castIsOk
@@ -958,12 +961,10 @@
 			    ; (case base of
 				  Operand.GCState => true
 				| _ => 
-				     (case Type.offset (Operand.ty base,
-							{offset = offset,
-							 pointerTy = tyconTy,
-							 width = Type.width ty}) of
-					 NONE => false
-				       | SOME t => Type.isSubtype (t, ty))))
+				     Type.offsetIsOk {base = Operand.ty base,
+						      offset = offset,
+						      pointerTy = tyconTy,
+						      result = ty}))
 		      | Real _ => true
 		      | Register _ => Alloc.doesDefine (alloc, x)
 		      | SmallIntInf w => 0wx1 = Word.andb (w, 0wx1)
@@ -1005,20 +1006,6 @@
 	       in
 		  Err.check ("operand", ok, fn () => Operand.layout x)
 	       end
-	    and arrayOffsetIsOk {base: Operand.t, index: Operand.t, ty} =
-	       Type.isSubtype (Operand.ty index, Type.defaultInt)
-	       andalso
-	       case Type.dest (Operand.ty base) of
-		  Type.Pointer p =>
-		     (case tyconTy p of
-			 ObjectType.Array ty' =>
-			    Type.isSubtype (ty', ty)
-			    orelse
-			    (* Get a word from a word8 array.*)
-			    (Type.equals (ty, Type.defaultWord)
-			     andalso Type.equals (ty', Type.word8))
-		       | _ => false)
-		| _ => Type.isCPointer (Operand.ty base)
 	    fun checkOperands (v, a) =
 	       Vector.foreach (v, fn z => checkOperand (z, a))
 	    fun check' (x, name, isOk, layout) =
@@ -1327,17 +1314,16 @@
 			   andalso jump (overflow, alloc)
 			   andalso jump (success, alloc)
 			   andalso
-			   (case (Prim.typeCheck
-				  (prim, Vector.map (args, Operand.ty))) of
-			       NONE => false
-			     | SOME t => Type.isSubtype (t, Operand.ty dst))
-
+			   Type.checkPrimApp
+			   {args = Vector.map (args, Operand.ty),
+			    prim = prim,
+			    result = SOME (Operand.ty dst)}
 			end
 		   | CCall {args, frameInfo = fi, func, return} =>
 			let
 			   val _ = checkOperands (args, alloc)
 			in
-			   CFunction.isOk func
+			   CFunction.isOk (func, {isUnit = Type.isUnit})
 			   andalso
 			   Vector.equals (args, CFunction.args func,
 					  fn (z, t) =>



1.43      +4 -4      mlton/mlton/backend/machine.sig

Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- machine.sig	4 Apr 2004 06:50:16 -0000	1.42
+++ machine.sig	12 Apr 2004 17:52:57 -0000	1.43
@@ -108,7 +108,7 @@
 				   value: Operand.t} vector}
 	     | PrimApp of {args: Operand.t vector,
 			   dst: Operand.t option,
-			   prim: Prim.t}
+			   prim: Type.t Prim.t}
 	     | ProfileLabel of ProfileLabel.t
 
 	    val foldOperands: t * 'a * (Operand.t * 'a -> 'a) -> 'a
@@ -136,11 +136,11 @@
 	       Arith of {args: Operand.t vector,
 			 dst: Operand.t,
 			 overflow: Label.t,
-			 prim: Prim.t,
+			 prim: Type.t Prim.t,
 			 success: Label.t}
 	     | CCall of {args: Operand.t vector,
 			 frameInfo: FrameInfo.t option,
-			 func: CFunction.t,
+			 func: Type.t CFunction.t,
 			 (* return is NONE iff the func doesn't return.
 			  * Else, return must be SOME l, where l is of CReturn
 			  * kind with a matching func.
@@ -167,7 +167,7 @@
 			frameInfo: FrameInfo.t}
 	     | CReturn of {dst: Operand.t option,
 			   frameInfo: FrameInfo.t option,
-			   func: CFunction.t}
+			   func: Type.t CFunction.t}
 	     | Func
 	     | Handler of {frameInfo: FrameInfo.t,
 			   handles: Operand.t vector}



1.34      +28 -0     mlton/mlton/backend/profile.fun

Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- profile.fun	4 Apr 2004 06:50:17 -0000	1.33
+++ profile.fun	12 Apr 2004 17:52:57 -0000	1.34
@@ -4,6 +4,34 @@
 open S
 open Rssa
 
+structure CFunction =
+   struct
+      open CFunction
+
+      local
+	 open Type
+      in
+	 val gcState = gcState
+	 val Word32 = word (Bits.fromInt 32)
+	 val unit = unit
+      end
+
+      val profileEnter =
+	 vanilla {args = Vector.new1 gcState,
+		  name = "GC_profileEnter",
+		  return = unit}
+
+      val profileInc =
+	 vanilla {args = Vector.new2 (gcState, Word32),
+		  name = "GC_profileInc",
+		  return = unit}
+	 
+      val profileLeave =
+	 vanilla {args = Vector.new1 gcState,
+		  name = "GC_profileLeave",
+		  return = unit}
+   end
+
 type sourceSeq = int list
 
 structure InfoNode =



1.48      +27 -45    mlton/mlton/backend/rssa.fun

Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- rssa.fun	4 Apr 2004 06:50:17 -0000	1.47
+++ rssa.fun	12 Apr 2004 17:52:57 -0000	1.48
@@ -168,7 +168,7 @@
 			     value: Operand.t} vector}
        | PrimApp of {args: Operand.t vector,
 		     dst: (Var.t * Type.t) option,
-		     prim: Prim.t}
+		     prim: Type.t Prim.t}
        | Profile of ProfileExp.t
        | ProfileLabel of ProfileLabel.t
        | SetExnStackLocal
@@ -272,11 +272,11 @@
 	 Arith of {args: Operand.t vector,
 		   dst: Var.t,
 		   overflow: Label.t,
-		   prim: Prim.t,
+		   prim: Type.t Prim.t,
 		   success: Label.t,
 		   ty: Type.t}
        | CCall of {args: Operand.t vector,
-		   func: CFunction.t,
+		   func: Type.t CFunction.t,
 		   return: Label.t option}
        | Call of {args: Operand.t vector,
 		  func: Func.t,
@@ -303,7 +303,7 @@
 	     | CCall {args, func, return} =>
 		  seq [str "CCall ",
 		       record [("args", Vector.layout Operand.layout args),
-			       ("func", CFunction.layout func),
+			       ("func", CFunction.layout (func, Type.layout)),
 			       ("return", Option.layout Label.layout return)]]
 	     | Call {args, func, return} =>
 		  seq [Func.layout func, str " ",
@@ -321,7 +321,7 @@
 	 CCall {args = (Vector.new1
 			(Operand.Const
 			 (Const.string "control shouldn't reach here"))),
-		func = CFunction.bug,
+		func = Type.BuiltInCFunction.bug,
 		return = NONE}
 
       fun 'a foldDefLabelUse (t, a: 'a,
@@ -406,7 +406,7 @@
    struct
       datatype t =
 	 Cont of {handler: Handler.t}
-       | CReturn of {func: CFunction.t}
+       | CReturn of {func: Type.t CFunction.t}
        | Handler
        | Jump
 
@@ -420,7 +420,7 @@
 		       record [("handler", Handler.layout handler)]]
 	     | CReturn {func} =>
 		  seq [str "CReturn ",
-		       record [("func", CFunction.layout func)]]
+		       record [("func", CFunction.layout (func, Type.layout))]]
 	     | Handler => str "Handler"
 	     | Jump => str "Jump"
 	 end
@@ -995,7 +995,13 @@
 		   datatype z = datatype Operand.t
 		   fun ok () =
 		      case x of
-			 ArrayOffset z => arrayOffsetIsOk z
+			 ArrayOffset {base, index, ty} =>
+			    (checkOperand base
+			     ; checkOperand index
+			     ; Type.arrayOffsetIsOk {base = Operand.ty base,
+						     index = Operand.ty index,
+						     pointerTy = tyconTy,
+						     result = ty})
 		       | Cast (z, ty) =>
 			    (checkOperand z
 			    ; (Type.castIsOk
@@ -1014,12 +1020,10 @@
 		       | GCState => true
 		       | Line => true
 		       | Offset {base, offset, ty} =>
-			    (case Type.offset (Operand.ty base,
-					       {offset = offset,
-						pointerTy = tyconTy,
-						width = Type.width ty}) of
-				NONE => false
-			      | SOME t => Type.isSubtype (t, ty))
+			    Type.offsetIsOk {base = Operand.ty base,
+					     offset = offset,
+					     pointerTy = tyconTy,
+					     result = ty}
 		       | PointerTycon _ => true
 		       | Runtime _ => true
 		       | SmallIntInf _ => true
@@ -1027,25 +1031,6 @@
 		in
 		   Err.check ("operand", ok, fn () => Operand.layout x)
 		end
-	    and arrayOffsetIsOk {base, index, ty} =
-	       let
-		  val _ = checkOperand base
-		  val _ = checkOperand index
-	       in
-		  Type.isSubtype (Operand.ty index, Type.defaultInt)
-		  andalso
-		  case Type.dest (Operand.ty base) of
-		     Type.Pointer p =>
-			(case tyconTy p of
-			    ObjectType.Array ty' =>
-			       Type.isSubtype (ty', ty)
-			       orelse
-			       (* Get a word from a word8 array.*)
-			       (Type.equals (ty, Type.defaultWord)
-				andalso Type.equals (ty', Type.word8))
-			  | _ => false)
-		   | _ => Type.isCPointer (Operand.ty base)
-	       end
 	    val checkOperand =
 	       Trace.trace ("checkOperand", Operand.layout, Unit.layout)
 	       checkOperand
@@ -1090,13 +1075,10 @@
 			end
 		   | PrimApp {args, dst, prim} =>
 			(Vector.foreach (args, checkOperand)
-			 ; (case (Prim.typeCheck
-				  (prim, Vector.map (args, Operand.ty))) of
-			       NONE => false
-			     | SOME t =>
-				  case dst of
-				     NONE => true
-				   | SOME (_, t') => Type.isSubtype (t, t')))
+			 ; (Type.checkPrimApp
+			    {args = Vector.map (args, Operand.ty),
+			     prim = prim,
+			     result = Option.map (dst, #2)}))
 		   | Profile _ => true
 		   | ProfileLabel _ => true
 		   | SetExnStackLocal => true
@@ -1210,16 +1192,16 @@
 				 andalso labelIsNullaryJump overflow
 				 andalso labelIsNullaryJump success
 				 andalso
-				 (case (Prim.typeCheck
-					(prim, Vector.map (args, Operand.ty))) of
-				     NONE => false
-				   | SOME t => Type.isSubtype (t, ty))
+				 Type.checkPrimApp
+				 {args = Vector.map (args, Operand.ty),
+				  prim = prim,
+				  result = SOME ty}
 			      end
 			 | CCall {args, func, return} =>
 			      let
 				 val _ = checkOperands args
 			      in
-				 CFunction.isOk func
+				 CFunction.isOk (func, {isUnit = Type.isUnit})
 				 andalso
 				 Vector.equals (args, CFunction.args func,
 						fn (z, t) =>



1.30      +4 -4      mlton/mlton/backend/rssa.sig

Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- rssa.sig	4 Apr 2004 06:50:17 -0000	1.29
+++ rssa.sig	12 Apr 2004 17:52:58 -0000	1.30
@@ -83,7 +83,7 @@
 				   value: Operand.t} vector}
 	     | PrimApp of {args: Operand.t vector,
 			   dst: (Var.t * Type.t) option,
-			   prim: Prim.t}
+			   prim: Type.t Prim.t}
 	     | Profile of ProfileExp.t
 	     | ProfileLabel of ProfileLabel.t
 	     | SetExnStackLocal
@@ -111,11 +111,11 @@
 	       Arith of {args: Operand.t vector,
 			 dst: Var.t,
 			 overflow: Label.t, (* Must be nullary. *)
-			 prim: Prim.t,
+			 prim: Type.t Prim.t,
 			 success: Label.t, (* Must be nullary. *)
 			 ty: Type.t}
 	     | CCall of {args: Operand.t vector,
-			 func: CFunction.t,
+			 func: Type.t CFunction.t,
 			 (* return is NONE iff the CFunction doesn't return.
 			  * Else, return must be SOME l, where l is of kind
 			  * CReturn.  The return should be nullary if the C
@@ -157,7 +157,7 @@
 	 sig
 	    datatype t =
 	       Cont of {handler: Handler.t}
-	     | CReturn of {func: CFunction.t}
+	     | CReturn of {func: Type.t CFunction.t}
 	     | Handler
 	     | Jump
 



1.22      +5 -0      mlton/mlton/backend/signal-check.fun

Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- signal-check.fun	16 Mar 2004 06:38:27 -0000	1.21
+++ signal-check.fun	12 Apr 2004 17:52:58 -0000	1.22
@@ -11,6 +11,11 @@
 open S
 open Rssa
 
+structure CFunction =
+   struct
+      open CFunction Type.BuiltInCFunction
+   end
+
 structure Graph = DirectedGraph
 local
    open Graph



1.67      +34 -4     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.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- ssa-to-rssa.fun	4 Apr 2004 06:50:17 -0000	1.66
+++ ssa-to-rssa.fun	12 Apr 2004 17:52:58 -0000	1.67
@@ -26,9 +26,19 @@
    structure GCField = GCField
 end
 
+structure Prim =
+   struct
+      open Prim
+
+      type t = Type.t Prim.t
+   end
+
 structure CFunction =
    struct
-      open CFunction 
+      open CFunction
+      open Type.BuiltInCFunction
+
+      type t = Type.t CFunction.t
 
       local
 	 open Type
@@ -106,6 +116,18 @@
 	 val unpack = make "GC_unpack"
       end
 
+      val returnToC =
+	 T {args = Vector.new0 (),
+	    bytesNeeded = NONE,
+	    convention = Cdecl,
+	    ensuresBytesFree = false,
+	    modifiesFrontier = true,
+	    modifiesStackTop = true,
+	    mayGC = true,
+	    maySwitchThreads = true,
+	    name = "Thread_returnToC",
+	    return = unit}
+
       val threadSwitchTo =
 	 T {args = Vector.new2 (Type.thread, Word32),
 	    bytesNeeded = NONE,
@@ -162,6 +184,8 @@
    struct
       open Prim.Name
 
+      type t = Type.t t
+
       fun cFunctionRaise (n: t): CFunction.t =
 	 let
 	    datatype z = datatype CFunction.Convention.t
@@ -591,9 +615,9 @@
 	      | _ => false
 	 end
 
-      val x86CodegenImplements =
+      val x86CodegenImplements: t -> bool =
 	 Trace.trace ("x86CodegenImplements", layout, Bool.layout)
-	  x86CodegenImplements
+	 x86CodegenImplements
    end
 
 datatype z = datatype Operand.t
@@ -823,6 +847,11 @@
 	 Vector.keepAllMap (xs, fn x =>
 			    Option.map (toRtype (varType x), fn _ =>
 					varOp x))
+      fun translatePrim p =
+	 Prim.map (p, fn t =>
+		   case toRtype t of
+		      NONE => Type.unit
+		    | SOME t => t)
       fun translateTransfer (t: S.Transfer.t): Statement.t list * Transfer.t =
 	 case t of
 	    S.Transfer.Arith {args, overflow, prim, success, ty} =>
@@ -843,7 +872,7 @@
 		  ([], Transfer.Arith {dst = temp,
 				       args = vos args,
 				       overflow = overflow,
-				       prim = prim,
+				       prim = translatePrim prim,
 				       success = noOverflow,
 				       ty = ty})
 	       end
@@ -990,6 +1019,7 @@
 			   end
 		      | S.Exp.PrimApp {prim, targs, args, ...} =>
 			   let
+			      val prim = translatePrim prim
 			      fun a i = Vector.sub (args, i)
 			      fun cast () =
 				 move (Operand.cast (varOp (a 0),



1.12      +2 -2      mlton/mlton/closure-convert/abstract-value.fun

Index: abstract-value.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- abstract-value.fun	19 Feb 2004 22:42:10 -0000	1.11
+++ abstract-value.fun	12 Apr 2004 17:52:59 -0000	1.12
@@ -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.
  *
@@ -373,7 +373,7 @@
 val {get = serialValue: Type.t -> t, ...} =
    Property.get (Type.plist, Property.initFun fromType)
 
-fun primApply {prim: Prim.t, args: t vector, resultTy: Type.t}: t =
+fun primApply {prim: Type.t Prim.t, args: t vector, resultTy: Type.t}: t =
    let 
       fun result () = fromType resultTy
       fun typeError () =



1.6       +2 -2      mlton/mlton/closure-convert/abstract-value.sig

Index: abstract-value.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- abstract-value.sig	9 Oct 2003 18:17:32 -0000	1.5
+++ abstract-value.sig	12 Apr 2004 17:52:59 -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.
  *
@@ -59,7 +59,7 @@
       val isEmpty: t -> bool (* no possible values correspond to me *) 
       val lambda: Sxml.Lambda.t * Sxml.Type.t (* The type of the lambda. *) -> t
       val layout: t -> Layout.t
-      val primApply: {prim: Sxml.Prim.t,
+      val primApply: {prim: Sxml.Type.t Sxml.Prim.t,
 		      args: t vector,
 		      resultTy: Sxml.Type.t} -> t
       val select: t * int -> t



1.34      +2 -1      mlton/mlton/closure-convert/closure-convert.fun

Index: closure-convert.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- closure-convert.fun	3 Mar 2004 02:09:02 -0000	1.33
+++ closure-convert.fun	12 Apr 2004 17:52:59 -0000	1.34
@@ -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.
  *
@@ -870,6 +870,7 @@
 		  end
 	     | SprimExp.PrimApp {prim, targs, args} =>
 		  let
+		     val prim = Prim.map (prim, convertType)
 		     open Prim.Name
 		     fun arg i = Vector.sub (args, i)
 		     val v1 = Vector.new1



1.5       +1 -1      mlton/mlton/closure-convert/closure-convert.sig

Index: closure-convert.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- closure-convert.sig	12 Dec 2002 01:14:22 -0000	1.4
+++ closure-convert.sig	12 Apr 2004 17:52:59 -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.
  *



1.77      +29 -5     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.76
retrieving revision 1.77
diff -u -r1.76 -r1.77
--- c-codegen.fun	4 Apr 2004 06:50:18 -0000	1.76
+++ c-codegen.fun	12 Apr 2004 17:53:00 -0000	1.77
@@ -35,7 +35,6 @@
    structure RealSize = RealSize
    structure RealX = RealX
    structure Register = Register
-   structure RepType = RepType
    structure Runtime = Runtime
    structure Statement = Statement
    structure Switch = Switch
@@ -67,6 +66,31 @@
 	  | _ => false
    end
 
+structure CFunction =
+   struct
+      open CFunction
+	 
+      fun prototype (T {args, convention, name, return, ...}) =
+	 let
+	    val c = Counter.new 0
+	    fun arg t = concat [CType.toString (Type.toCType t),
+				" x", Int.toString (Counter.next c)]
+	 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), ", ")),
+		   ")"]
+	 end
+   end
+
 val traceGotoLabel = Trace.trace ("gotoLabel", Label.layout, Unit.layout) 
 
 structure IntX =
@@ -187,8 +211,8 @@
 	  | _ => false
    end
 
-fun creturn (t: RepType.t): string =
-   concat ["CReturn", CType.name (RepType.toCType t)]
+fun creturn (t: Type.t): string =
+   concat ["CReturn", CType.name (Type.toCType t)]
 
 fun outputIncludes (includes, print) =
    (List.foreach (includes, fn i => (print "#include <";
@@ -658,7 +682,7 @@
 				       (name, fn () =>
 					concat
 					["extern ",
-					 CType.toString (RepType.toCType ty),
+					 CType.toString (Type.toCType ty),
 					    " ", name, ";\n"])
 				  | _ => ())
 			   | _ => ())
@@ -971,7 +995,7 @@
 			      else ()
 			   val _ = print "\t"
 			   val _ =
-			      if RepType.isUnit returnTy
+			      if Type.isUnit returnTy
 				 then ()
 			      else print (concat [creturn returnTy, " = "])
 			   val _ = C.call (name, args, print)



1.29      +2 -2      mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun

Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- x86-mlton-basic.fun	4 Apr 2004 06:50:19 -0000	1.28
+++ x86-mlton-basic.fun	12 Apr 2004 17:53:00 -0000	1.29
@@ -1,11 +1,11 @@
-(* 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 x86MLtonBasic(S: X86_MLTON_BASIC_STRUCTS): X86_MLTON_BASIC =
+functor x86MLtonBasic (S: X86_MLTON_BASIC_STRUCTS): X86_MLTON_BASIC =
 struct
 
   open S



1.30      +11 -2     mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig

Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- x86-mlton-basic.sig	4 Apr 2004 06:50:19 -0000	1.29
+++ x86-mlton-basic.sig	12 Apr 2004 17:53:01 -0000	1.30
@@ -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.
  *
@@ -9,17 +9,26 @@
 
 signature X86_MLTON_BASIC_STRUCTS =
   sig
-    structure x86 : X86_PSEUDO
     structure Machine: MACHINE
+    structure x86: X86_PSEUDO
     sharing x86.CFunction = Machine.CFunction
+    sharing x86.CType = Machine.CType
     sharing x86.Label = Machine.Label
     sharing x86.ProfileLabel = Machine.ProfileLabel
+    sharing x86.RepType = Machine.RepType
     sharing x86.Runtime = Machine.Runtime
   end
 
 signature X86_MLTON_BASIC =
   sig
     include X86_MLTON_BASIC_STRUCTS
+
+    structure CFunction: C_FUNCTION
+    structure CType: C_TYPE
+    structure RepType: REP_TYPE
+    sharing CFunction = RepType.CFunction
+    sharing CType = RepType.CType
+    sharing RepType = Machine.RepType
 
     val init : unit -> unit
 



1.58      +3 -3      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.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- x86-mlton.fun	5 Mar 2004 03:50:53 -0000	1.57
+++ x86-mlton.fun	12 Apr 2004 17:53:01 -0000	1.58
@@ -29,7 +29,7 @@
 		    live: x86.Label.t -> x86.Operand.t list,
 		    liveInfo: x86Liveness.LiveInfo.t}
 
-  fun prim {prim : Prim.t,
+  fun prim {prim : RepType.t Prim.t,
 	    args : (Operand.t * Size.t) vector,
 	    dsts : (Operand.t * Size.t) vector,
 	    transInfo = {...} : transInfo}
@@ -1582,7 +1582,7 @@
 
   fun creturn {dsts: (x86.Operand.t * x86.Size.t) vector,
 	       frameInfo: x86.FrameInfo.t option,
-	       func: CFunction.t,
+	       func: RepType.t CFunction.t,
 	       label: x86.Label.t, 
 	       transInfo = {live, liveInfo, ...}: transInfo}
     = let
@@ -1613,7 +1613,7 @@
 	AppendList.appends [default (), comment_end]
       end
 
-  fun arith {prim : Prim.t,
+  fun arith {prim : RepType.t Prim.t,
 	     args : (Operand.t * Size.t) vector,
 	     dsts : (Operand.t * Size.t) vector,
 	     overflow : Label.t,



1.17      +5 -5      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.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- x86-mlton.sig	18 Mar 2004 03:22:24 -0000	1.16
+++ x86-mlton.sig	12 Apr 2004 17:53:01 -0000	1.17
@@ -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.
  *
@@ -28,7 +28,7 @@
 		      liveInfo: x86Liveness.LiveInfo.t}
 
     (* arith, c call, and primitive assembly sequences. *)
-    val arith: {prim: Machine.Prim.t,
+    val arith: {prim: RepType.t Machine.Prim.t,
 		args: (x86.Operand.t * x86.Size.t) vector,
 		dsts: (x86.Operand.t * x86.Size.t) vector,
 		overflow: x86.Label.t,
@@ -36,15 +36,15 @@
 		transInfo : transInfo} -> x86.Block.t' AppendList.t
     val ccall: {args: (x86.Operand.t * x86.Size.t) vector,
 		frameInfo: x86.FrameInfo.t option,
-		func: Machine.CFunction.t,
+		func: RepType.t Machine.CFunction.t,
 		return: x86.Label.t option,
 		transInfo: transInfo} -> x86.Block.t' AppendList.t
     val creturn: {dsts: (x86.Operand.t * x86.Size.t) vector,
 		  frameInfo: x86.FrameInfo.t option,
-		  func: Machine.CFunction.t,
+		  func: RepType.t Machine.CFunction.t,
 		  label: x86.Label.t, 
 		  transInfo: transInfo} -> x86.Block.t' AppendList.t
-    val prim: {prim: Machine.Prim.t,
+    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.23      +5 -3      mlton/mlton/codegen/x86-codegen/x86-pseudo.sig

Index: x86-pseudo.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-pseudo.sig,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- x86-pseudo.sig	4 Apr 2004 06:50:19 -0000	1.22
+++ x86-pseudo.sig	12 Apr 2004 17:53:01 -0000	1.23
@@ -13,8 +13,10 @@
     structure CFunction: C_FUNCTION
     structure CType: C_TYPE
     structure Label: ID
+    structure RepType: REP_TYPE
     structure Runtime: RUNTIME
-    sharing CType = CFunction.RepType.CType
+    sharing CFunction = RepType.CFunction
+    sharing CType = RepType.CType
 
     val tracer : string -> ('a -> 'b) -> 
                  (('a -> 'b) * (unit -> unit))
@@ -425,7 +427,7 @@
 		   frameInfo: FrameInfo.t} -> t
 	val creturn: {dsts: (Operand.t * Size.t) vector,
 		      frameInfo: FrameInfo.t option,
-		      func: CFunction.t,
+		      func: RepType.t CFunction.t,
 		      label: Label.t} -> t
 	val func: {label: Label.t,
 		   live: MemLocSet.t} -> t
@@ -467,7 +469,7 @@
 	val raisee : {live: MemLocSet.t} -> t
 	val ccall : {args: (Operand.t * Size.t) list,
 		     frameInfo: FrameInfo.t option,
-		     func: CFunction.t,
+		     func: RepType.t CFunction.t,
 		     return: Label.t option,
 		     target: Label.t} -> t
       end



1.52      +2 -4      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.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- x86.fun	4 Apr 2004 06:50:19 -0000	1.51
+++ x86.fun	12 Apr 2004 17:53:02 -0000	1.52
@@ -43,8 +43,6 @@
 
   open S
 
-  structure RepType = CFunction.RepType
-
   structure Label =
      struct
 	open Label
@@ -3720,7 +3718,7 @@
 		      live: MemLocSet.t}
 	| CReturn of {dsts: (Operand.t * Size.t) vector,
 		      frameInfo: FrameInfo.t option,
-		      func: CFunction.t,
+		      func: RepType.t CFunction.t,
 		      label: Label.t}
 				    
       val toString
@@ -3979,7 +3977,7 @@
 	| Raise of {live: MemLocSet.t}
 	| CCall of {args: (Operand.t * Size.t) list,
 		    frameInfo: FrameInfo.t option,
-		    func: CFunction.t,
+		    func: RepType.t CFunction.t,
 		    return: Label.t option,
 		    target: Label.t}
 



1.32      +13 -9     mlton/mlton/codegen/x86-codegen/x86.sig

Index: x86.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.sig,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- x86.sig	4 Apr 2004 06:50:19 -0000	1.31
+++ x86.sig	12 Apr 2004 17:53:02 -0000	1.32
@@ -13,18 +13,22 @@
     structure CFunction: C_FUNCTION
     structure CType: C_TYPE
     structure Label: ID
-    structure ProfileLabel: PROFILE_LABEL
+    structure ProfileLabel: PROFILE_LABEL 
+    structure RepType: REP_TYPE
     structure Runtime: RUNTIME
-    sharing CType = CFunction.RepType.CType
+    sharing CFunction = RepType.CFunction
+    sharing CType = RepType.CType
   end
 
 signature X86 =
   sig
     structure CFunction: C_FUNCTION
+    structure CType: C_TYPE
     structure Label: ID
+    structure RepType: REP_TYPE
     structure Runtime: RUNTIME
-    structure CType: C_TYPE
-    sharing CType = CFunction.RepType.CType
+    sharing CFunction = RepType.CFunction
+    sharing CType = RepType.CType
 
     val tracer : string -> ('a -> 'b) -> 
                  (('a -> 'b) * (unit -> unit))
@@ -307,7 +311,7 @@
 	val size : t -> Size.t option
 	val eq : t * t -> bool
 
-	val cReturnTemps: CFunction.RepType.t -> {src: t, dst: MemLoc.t} list
+	val cReturnTemps: RepType.t -> {src: t, dst: MemLoc.t} list
       end
 
     structure Instruction :
@@ -1073,7 +1077,7 @@
 			live: MemLocSet.t}
 	  | CReturn of {dsts: (Operand.t * Size.t) vector,
 			frameInfo: FrameInfo.t option,
-			func: CFunction.t,
+			func: RepType.t CFunction.t,
 			label: Label.t}
 
 	val cont : {label: Label.t,
@@ -1081,7 +1085,7 @@
 		    frameInfo: FrameInfo.t} -> t
 	val creturn: {dsts: (Operand.t * Size.t) vector,
 		      frameInfo: FrameInfo.t option,
-		      func: CFunction.t,
+		      func: RepType.t CFunction.t,
 		      label: Label.t}  -> t
 	val func : {label: Label.t,
 		    live: MemLocSet.t} -> t
@@ -1161,7 +1165,7 @@
 	  | Raise of {live: MemLocSet.t}
 	  | CCall of {args: (Operand.t * Size.t) list,
 		      frameInfo: FrameInfo.t option,
-		      func: CFunction.t,
+		      func: RepType.t CFunction.t,
 		      return: Label.t option,
 		      target: Label.t}
 
@@ -1193,7 +1197,7 @@
 	val raisee : {live: MemLocSet.t} -> t
 	val ccall: {args: (Operand.t * Size.t) list,
 		    frameInfo: FrameInfo.t option,
-		    func: CFunction.t,
+		    func: RepType.t CFunction.t,
 		    return: Label.t option,
 		    target: Label.t} -> t		       
       end



1.18      +1 -1      mlton/mlton/core-ml/core-ml.fun

Index: core-ml.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- core-ml.fun	19 Feb 2004 22:42:11 -0000	1.17
+++ core-ml.fun	12 Apr 2004 17:53:03 -0000	1.18
@@ -165,7 +165,7 @@
   | Let of dec vector * exp
   | List of exp vector
   | PrimApp of {args: exp vector,
-		prim: Prim.t,
+		prim: Type.t Prim.t,
 		targs: Type.t vector}
   | Raise of {exn: exp,
 	      region: Region.t}



1.17      +1 -1      mlton/mlton/core-ml/core-ml.sig

Index: core-ml.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.sig,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- core-ml.sig	18 Mar 2004 03:22:25 -0000	1.16
+++ core-ml.sig	12 Apr 2004 17:53:04 -0000	1.17
@@ -86,7 +86,7 @@
 	     | Let of dec vector * t
 	     | List of t vector
 	     | PrimApp of {args: t vector,
-			   prim: Prim.t,
+			   prim: Type.t Prim.t,
 			   targs: Type.t vector}
 	     | Raise of {exn: t,
 			 region: Region.t}



1.16      +13 -13    mlton/mlton/defunctorize/defunctorize.fun

Index: defunctorize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/defunctorize.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- defunctorize.fun	18 Mar 2004 03:22:25 -0000	1.15
+++ defunctorize.fun	12 Apr 2004 17:53:04 -0000	1.16
@@ -806,21 +806,21 @@
 		| PrimApp {args, prim, targs} =>
 		     let
 			val args = Vector.map (args, #1 o loopExp)
-			val targs = Vector.map (targs, loopTy)
-			fun app prim =
-			   Xexp.primApp {args = args,
-					 prim = prim,
-					 targs = targs,
-					 ty = ty}
-			fun id () = Vector.sub (args, 0)
 			datatype z = datatype Prim.Name.t
 		     in
-			case Prim.name prim of
-			   Char_toWord8 => id ()
-			 | String_toWord8Vector => id ()
-			 | Word8_toChar => id ()
-			 | Word8Vector_toString => id ()
-			 | _ => app prim
+			if (case Prim.name prim of
+			       Char_toWord8 => true
+			     | String_toWord8Vector => true
+			     | Word8_toChar => true
+			     | Word8Vector_toString => true
+			     | _ => false)
+			   then Vector.sub (args, 0)
+			else
+			   Xexp.primApp {args = args,
+					 prim = Prim.map (prim, loopTy),
+					 targs = Vector.map (targs, loopTy),
+					 ty = ty}
+
 		     end
 		| Raise {exn, region} =>
 		     Xexp.raisee ({exn = #1 (loopExp exn),



1.97      +102 -74   mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.96
retrieving revision 1.97
diff -u -r1.96 -r1.97
--- elaborate-core.fun	4 Apr 2004 06:50:20 -0000	1.96
+++ elaborate-core.fun	12 Apr 2004 17:53:04 -0000	1.97
@@ -628,9 +628,9 @@
 val info = Trace.info "elaborateDec"
 val elabExpInfo = Trace.info "elaborateExp"
 
-structure RepType =
+structure Type =
    struct
-      open CoreML.RepType
+      open Type
 
       fun sized (all: 'a list,
 		 toString: 'a -> string,
@@ -640,65 +640,97 @@
 	 List.map (all, fn a =>
 		   (make a, concat [prefix, toString a], makeType a))
 
-      val nullary: (t * string * Tycon.t) list =
-	 [(bool, "Bool", Tycon.bool),
-	  (char, "Char", Tycon.char),
-	  (cPointer (), "Pointer", Tycon.pointer),
-	  (thread, "Pointer", Tycon.preThread),
-	  (thread, "Pointer", Tycon.thread)]
-	 @ sized (IntSize.all, IntSize.toString, "Int", int, Tycon.int)
-	 @ sized (RealSize.all, RealSize.toString, "Real", real, Tycon.real)
-	 @ sized (WordSize.all, WordSize.toString, "Word",
-		  word o WordSize.bits,
-		  Tycon.word)
+      val nullary: (string * CType.t * Tycon.t) list =
+	 let
+	    fun sized (tycon: Bits.t -> Tycon.t) =
+	       List.map
+	       ([CType.Word8, CType.Word16, CType.Word32, CType.Word64],
+		fn cty =>
+		let
+		   val c = tycon (Bytes.toBits (CType.size cty))
+		   val s = Tycon.toString c
+		   val s =
+		      CharVector.tabulate
+		      (String.size s, fn i =>
+		       let
+			  val c = String.sub (s, i)
+		       in
+			  if i = 0 then Char.toUpper c else c
+		       end)
+		in
+		   (s, cty, c)
+		end)
+	 in
+	    [("Bool", CType.bool, Tycon.bool),
+	     ("Char", CType.char, Tycon.char),
+	     ("Pointer", CType.preThread, Tycon.preThread),
+	     ("Thread", CType.thread, Tycon.thread)]
+	    @ sized (Tycon.int o IntSize.I)
+	    @ [("Real32", CType.Real32, Tycon.real RealSize.R32),
+	       ("Real64", CType.Real64, Tycon.real RealSize.R64)]
+	    @ sized (Tycon.word o WordSize.fromBits)
+	 end
+
+      val nullary =
+	 List.map (nullary, fn (name, ctype, tycon) =>
+		   {ctype = ctype, name = name, tycon = tycon})
 
       val unary: Tycon.t list =
 	 [Tycon.array, Tycon.reff, Tycon.vector]
 
-      fun fromType (t: Type.t): (t * string) option =
-	 case Type.deConOpt t of
+      fun toCType (t: t): {ctype: CType.t, name: string} option =
+	 case deConOpt t of
 	    NONE => NONE
 	  | SOME (c, ts) =>
-	       case List.peek (nullary, fn (_, _, c') => Tycon.equals (c, c')) of
+	       case List.peek (nullary, fn {tycon = c', ...} =>
+			       Tycon.equals (c, c')) of
 		  NONE =>
 		     if List.exists (unary, fn c' => Tycon.equals (c, c'))
 			andalso 1 = Vector.length ts
-			andalso isSome (fromType (Vector.sub (ts, 0)))
-			then SOME (cPointer (), "Pointer")
+			andalso isSome (toCType (Vector.sub (ts, 0)))
+			then SOME {ctype = CType.pointer, name = "Pointer"}
 		     else NONE
-		| SOME (t, s, _) => SOME (t, s)
-
-      val fromType =
-	 Trace.trace ("RepType.fromType",
-		      Type.layoutPretty,
-		      Option.layout (Layout.tuple2 (layout, String.layout)))
-	 fromType
+		| SOME {ctype, name, ...} => SOME {ctype = ctype, name = name}
 
-      fun parse (ty: Type.t)
-	 : ((t * string) vector * (t * string) option) option =
-	 case Type.deArrowOpt ty of
+      type z = {ctype: CType.t, name: string, ty: t}
+	 
+      fun parse (ty: t): (z vector * z option) option =
+	 case deArrowOpt ty of
 	    NONE => NONE
 	  | SOME (t1, t2) =>
 	       let
-		  fun finish (ts: (t * string) vector) =
-		     case fromType t2 of
+		  fun finish (ts: z vector) =
+		     case toCType t2 of
 			NONE =>
 			   if Type.isUnit t2
 			      then SOME (ts, NONE)
 			   else NONE
-		      | SOME t => SOME (ts, SOME t)
+		      | SOME {ctype, name} =>
+			   SOME (ts, SOME {ctype = ctype, name = name, ty = t2})
 	       in
-		  case Type.deTupleOpt t1 of 
+		  case deTupleOpt t1 of 
 		     NONE =>
-			(case fromType t1 of
+			(case toCType t1 of
 			    NONE => NONE
-			  | SOME u => finish (Vector.new1 u))
+			  | SOME {ctype, name} =>
+			       finish (Vector.new1 {ctype = ctype,
+						    name = name,
+						    ty = t1}))
 		   | SOME ts =>
 			let
-			   val us = Vector.map (ts, fromType)
+			   val cts = Vector.map (ts, toCType)
 			in
-			   if Vector.forall (us, isSome)
-			      then finish (Vector.map (us, valOf))
+			   if Vector.forall (cts, isSome)
+			      then
+				 finish (Vector.map2
+					 (ts, cts, fn (ty, z) =>
+					  let
+					     val {ctype, name} = valOf z
+					  in
+					     {ctype = ctype,
+					      name = name,
+					      ty = ty}
+					  end))
 			   else NONE
 			end
 	       end
@@ -719,35 +751,34 @@
 fun import {attributes: Attribute.t list,
 	    name: string,
 	    ty: Type.t,
-	    region: Region.t}: Prim.t =
+	    region: Region.t}: Type.t Prim.t =
    let
       fun error l = Control.error (region, l, Layout.empty)
       fun invalidAttributes () =
 	 error (seq [str "invalid attributes for import: ",
 		     List.layout Attribute.layout attributes])
    in
-      case RepType.parse ty of
+      case Type.parse ty of
 	 NONE =>
-	    (case RepType.fromType ty of
-		NONE => 
-		   let
-		      val _ =
-			 Control.error
-			 (region,
-			  str "invalid type for import: ",
-			  Type.layoutPretty ty)
-		   in
-		      Prim.bogus
-		   end
-	      | SOME (t, _) =>
-		   case attributes of
-		      [] => Prim.ffiSymbol {name = name, ty = t}
+	    if isSome (Type.toCType ty)
+	       then
+		  (case attributes of
+		      [] => Prim.ffiSymbol {name = name, ty = ty}
 		    | _ => 
 			 let
-			    val _ = invalidAttributes ()
+			    val () = invalidAttributes ()
 			 in
 			    Prim.bogus
 			 end)
+	    else
+	       let
+		  val () =
+		     Control.error (region,
+				    str "invalid type for import: ",
+				    Type.layoutPretty ty)
+	       in
+		  Prim.bogus
+	       end
        | SOME (args, result) =>
 	    let
 	       val convention =
@@ -756,7 +787,7 @@
 			      ; Convention.Cdecl)
 		   | SOME c => c
 	       val func =
-		  CFunction.T {args = Vector.map (args, #1),
+		  CFunction.T {args = Vector.map (args, #ty),
 			       bytesNeeded = NONE,
 			       convention = convention,
 			       ensuresBytesFree = false,
@@ -766,8 +797,8 @@
 			       maySwitchThreads = false,
 			       name = name,
 			       return = (case result of
-					    NONE => RepType.unit
-					  | SOME (t, _) => t)}
+					    NONE => Type.unit
+					  | SOME {ty, ...} => ty)}
 	    in
 	       Prim.ffi func
 	    end
@@ -785,29 +816,27 @@
 		     ; Convention.Cdecl)
 	  | SOME c => c
       val (exportId, args, res) =
-	 case RepType.parse ty of
+	 case Type.parse ty of
 	    NONE =>
-	       (Control.error
-		(region,
-		 seq [str "invalid type for exported function: ",
-		      Type.layoutPretty ty],
-		 Layout.empty)
+	       (Control.error (region,
+			       seq [str "invalid type for exported function: ",
+				    Type.layoutPretty ty],
+			       Layout.empty)
 		; (0, Vector.new0 (), NONE))
-	  | SOME (us, t) =>
+	  | SOME (args, result) =>
 	       let
 		  val id =
-		     Ffi.addExport {args = Vector.map (us, RepType.toCType o #1),
+		     Ffi.addExport {args = Vector.map (args, #ctype),
 				    convention = convention,
 				    name = name,
-				    res = Option.map (t, RepType.toCType o #1)}
+				    res = Option.map (result, #ctype)}
 	       in
-		  (id, us, t)
+		  (id, args, result)
 	       end
       open Ast
       fun id (name: string) =
 	 Aexp.longvid (Longvid.short
-		       (Vid.fromSymbol (Symbol.fromString name,
-					region)))
+		       (Vid.fromSymbol (Symbol.fromString name, region)))
       fun int (i: int): Aexp.t =
 	 Aexp.const (Aconst.makeRegion (Aconst.Int (IntInf.fromInt i), region))
       val f = Var.fromSymbol (Symbol.fromString "f", region)
@@ -829,9 +858,8 @@
 		val (args, decs) =
 		   Vector.unzip
 		   (Vector.map
-		    (args, fn (u, name) =>
+		    (args, fn {ctype, name, ...} =>
 		     let
-			val u = RepType.toCType u
 			val x =
 			   Var.fromSymbol
 			   (Symbol.fromString
@@ -842,7 +870,7 @@
 			   Dec.vall (Vector.new0 (),
 				     x,
 				     Exp.app (id (concat ["get", name]),
-					      int (Counter.next (map u))))
+					      int (Counter.next (map ctype))))
 		     in
 			(x, dec)
 		     end))
@@ -861,7 +889,7 @@
 		    (newVar (),
 		     (case res of
 			 NONE => Exp.constraint (Exp.var resVar, Type.unit)
-		       | SOME (_, name) => 
+		       | SOME {name, ...} => 
 			    Exp.app (id (concat ["set", name]),
 				     Exp.var resVar)))),
 		   fn (x, e) => Dec.vall (Vector.new0 (), x, e))],
@@ -1975,7 +2003,7 @@
 						     targs = targs},
 				       result)
 			 end
-		      fun eta (p: Prim.t): Cexp.t =
+		      fun eta (p: Type.t Prim.t): Cexp.t =
 			 case Type.deArrowOpt expandedTy of
 			    NONE =>
 			       wrap (primApp {args = Vector.new0 (),



1.34      +15 -10    mlton/mlton/elaborate/type-env.fun

Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- type-env.fun	4 Apr 2004 06:50:21 -0000	1.33
+++ type-env.fun	12 Apr 2004 17:53:04 -0000	1.34
@@ -1172,7 +1172,13 @@
 	  | UnifyResult.Unified => Unified
 
       val word8 = word WordSize.byte
-	 
+
+      val synonyms =
+	 List.map
+	 ([(Tycon.char, Tycon.word WordSize.byte),
+	   (Tycon.preThread, Tycon.thread)],
+	  fn (c, c') => (c, c', con (c, Vector.new0 ())))
+
       fun 'a simpleHom {con: t * Tycon.t * 'a vector -> 'a,
 			expandOpaque: bool,
 			record: t * (Field.t * 'a) vector -> 'a,
@@ -1217,15 +1223,14 @@
 	    val real = default (real RealSize.default, Tycon.defaultReal)
 	    val word = default (word WordSize.default, Tycon.defaultWord)
 	    val con =
-	       fn (t, c, ts) =>
-	       if replaceSynonyms
-		  then if Tycon.equals (c, Tycon.char)
-			  then con (word8, Tycon.word WordSize.byte,
-				    Vector.new0 ())
-		       else if Tycon.equals (c, Tycon.preThread)
-			       then con (thread, Tycon.thread, Vector.new0 ())
-			    else con (t, c, ts)
-	       else con (t, c, ts)
+	       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 ())
 	 in
 	    makeHom {con = con,
 		     expandOpaque = expandOpaque,



1.12      +1 -1      mlton/mlton/ssa/analyze.sig

Index: analyze.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- analyze.sig	18 Mar 2004 03:22:25 -0000	1.11
+++ analyze.sig	12 Apr 2004 17:53:05 -0000	1.12
@@ -28,7 +28,7 @@
 	  fromType: Type.t -> 'a,
 	  layout: 'a -> Layout.t,
 	  primApp: {args: 'a vector,
-		    prim: Prim.t,
+		    prim: Type.t Prim.t,
 		    resultType: Type.t,
 		    resultVar: Var.t option,
 		    targs: Type.t vector} -> 'a,



1.17      +3 -3      mlton/mlton/ssa/direct-exp.fun

Index: direct-exp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- direct-exp.fun	18 Feb 2004 04:24:10 -0000	1.16
+++ direct-exp.fun	12 Apr 2004 17:53:05 -0000	1.17
@@ -14,7 +14,7 @@
 struct
    
 datatype t =
-   Arith of {prim: Prim.t,
+   Arith of {prim: Type.t Prim.t,
 	     args: t vector,
 	     overflow: t,
 	     ty: Type.t}
@@ -43,14 +43,14 @@
  | Let of {decs: {var: Var.t, exp: t} list,
 	   body: t}
  | Name of t * (Var.t -> t)
- | PrimApp of {prim: Prim.t,
+ | PrimApp of {prim: Type.t Prim.t,
 	       targs: Type.t vector,
 	       args: t vector,
 	       ty: Type.t}
  | Profile of ProfileExp.t
  | Raise of t
  | Runtime of {args: t vector,
-	       prim: Prim.t,
+	       prim: Type.t Prim.t,
 	       ty: Type.t}
  | Select of {tuple: t,
 	      offset: int,



1.14      +2 -2      mlton/mlton/ssa/direct-exp.sig

Index: direct-exp.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.sig,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- direct-exp.sig	18 Mar 2004 03:22:25 -0000	1.13
+++ direct-exp.sig	12 Apr 2004 17:53:05 -0000	1.14
@@ -27,7 +27,7 @@
 	    | Int of IntSize.t * (IntX.t * t) vector
 	    | Word of WordSize.t * (WordX.t * t) vector
 
-	   val arith: {prim: Prim.t,
+	   val arith: {prim: Type.t Prim.t,
 		       args: t vector,
 		       overflow: t,
 		       ty: Type.t} -> t
@@ -66,7 +66,7 @@
 	      t * Return.Handler.t * Label.t -> Label.t * Block.t list
 	   val name: t * (Var.t -> t) -> t
 	   val primApp: {args: t vector,
-			 prim: Prim.t,
+			 prim: Type.t Prim.t,
 			 targs: Type.t vector, 
 			 ty: Type.t} -> t
 	   val profile: ProfileExp.t -> t



1.19      +4 -2      mlton/mlton/ssa/redundant-tests.fun

Index: redundant-tests.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/redundant-tests.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- redundant-tests.fun	18 Mar 2004 03:22:25 -0000	1.18
+++ redundant-tests.fun	12 Apr 2004 17:53:05 -0000	1.19
@@ -367,11 +367,13 @@
 			end)
 		    val noChange = (statements, transfer)
 		    fun arith (args: Var.t vector,
-			       prim: Prim.t,
+			       prim: Type.t Prim.t,
 			       success: Label.t)
 		       : Statement.t vector * Transfer.t =
 		       let
-			  fun simplify (prim: Prim.t, x: Var.t, s: IntSize.t) =
+			  fun simplify (prim: Type.t Prim.t,
+					x: Var.t,
+					s: IntSize.t) =
 			     let
 				val res = Var.newNoname ()
 			     in



1.39      +15 -12    mlton/mlton/ssa/shrink.fun

Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- shrink.fun	4 Apr 2004 06:50:21 -0000	1.38
+++ shrink.fun	12 Apr 2004 17:53:05 -0000	1.39
@@ -172,15 +172,7 @@
 	 end
    end
 
-val traceApply =
-   Trace.trace ("Prim.apply",
-		fn (p, args, _: VarInfo.t * VarInfo.t -> bool) =>
-		let open Layout
-		in seq [Prim.layout p, str " ",
-			List.layout (Prim.ApplyArg.layout
-				     (Var.layout o VarInfo.var)) args]
-		end,
-		Prim.ApplyResult.layout (Var.layout o VarInfo.var))
+val traceApplyInfo = Trace.info "Prim.apply"
 
 fun shrinkFunction (globals: Statement.t vector) =
    let
@@ -619,8 +611,8 @@
 		     end
 	       else ()
 	    end) arg
-	 fun primApp (prim: Prim.t, args: VarInfo.t vector)
-	    : VarInfo.t Prim.ApplyResult.t =
+	 fun primApp (prim: Type.t Prim.t, args: VarInfo.t vector)
+	    : (Type.t, VarInfo.t) Prim.ApplyResult.t =
 	    case Prim.name prim of
 	       Prim.Name.FFI _ => Prim.ApplyResult.Unknown
 	     | _ =>
@@ -642,7 +634,18 @@
 				 | _ => Prim.ApplyArg.Var vi)
 			  | _ => Prim.ApplyArg.Var vi)
 		  in
-		     traceApply Prim.apply
+		     Trace.traceInfo'
+		     (traceApplyInfo,
+		      fn (p, args, _) =>
+		      let
+			 open Layout
+		      in
+			 seq [Prim.layout p, str " ",
+			      List.layout (Prim.ApplyArg.layout
+					   (Var.layout o VarInfo.var)) args]
+		      end,
+		      Prim.ApplyResult.layout (Var.layout o VarInfo.var))
+		     Prim.apply
 		     (prim, Vector.toList args', VarInfo.equals)
 		     handle e =>
 			Error.bug (concat ["Prim.apply raised ",



1.69      +3 -3      mlton/mlton/ssa/ssa-tree.fun

Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.68
retrieving revision 1.69
diff -u -r1.68 -r1.69
--- ssa-tree.fun	4 Apr 2004 06:50:21 -0000	1.68
+++ ssa-tree.fun	12 Apr 2004 17:53:06 -0000	1.69
@@ -210,7 +210,7 @@
 	 ConApp of {con: Con.t,
 		    args: Var.t vector}
        | Const of Const.t
-       | PrimApp of {prim: Prim.t,
+       | PrimApp of {prim: Type.t Prim.t,
 		     targs: Type.t vector,
 		     args: Var.t vector}
        | Profile of ProfileExp.t
@@ -573,7 +573,7 @@
 structure Transfer =
    struct
       datatype t =
-         Arith of {prim: Prim.t,
+         Arith of {prim: Type.t Prim.t,
 		   args: Var.t vector,
 		   overflow: Label.t, (* Must be nullary. *)
 		   success: Label.t, (* Must be unary. *)
@@ -589,7 +589,7 @@
 		  args: Var.t vector}
        | Raise of Var.t vector
        | Return of Var.t vector
-       | Runtime of {prim: Prim.t,
+       | Runtime of {prim: Type.t Prim.t,
 		     args: Var.t vector,
 		     return: Label.t} (* Must be nullary. *)
 



1.56      +5 -5      mlton/mlton/ssa/ssa-tree.sig

Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- ssa-tree.sig	4 Apr 2004 06:50:21 -0000	1.55
+++ ssa-tree.sig	12 Apr 2004 17:53:07 -0000	1.56
@@ -82,7 +82,7 @@
 			  con: Con.t}
 	     | Const of Const.t
 	     | PrimApp of {args: Var.t vector,
-			   prim: Prim.t,
+			   prim: Type.t Prim.t,
 			   targs: Type.t vector}
 	     | Profile of ProfileExp.t
 	     | Select of {offset: int,
@@ -142,7 +142,7 @@
 	    datatype t =
 	       Arith of {args: Var.t vector,
 			 overflow: Label.t, (* Must be nullary. *)
-			 prim: Prim.t,
+			 prim: Type.t Prim.t,
 			 success: Label.t, (* Must be unary. *)
 			 ty: Type.t} (* int or word *)
 	     | Bug  (* MLton thought control couldn't reach here. *)
@@ -160,7 +160,7 @@
 	     | Raise of Var.t vector
 	     | Return of Var.t vector
 	     | Runtime of {args: Var.t vector,
-			   prim: Prim.t,
+			   prim: Type.t Prim.t,
 			   return: Label.t} (* Must be nullary. *)
 
 	    val equals: t * t -> bool
@@ -254,9 +254,9 @@
 
 	    val clear: t -> unit
 	    val clearTop: t -> unit
-	    val foreachPrim: t * (Prim.t -> unit) -> unit
+	    val foreachPrim: t * (Type.t Prim.t -> unit) -> unit
 	    val foreachVar: t * (Var.t * Type.t -> unit) -> unit
-	    val hasPrim: t * (Prim.t -> bool) -> bool
+	    val hasPrim: t * (Type.t Prim.t -> bool) -> bool
 	    val layouts: t * (Layout.t -> unit) -> unit
 	    val layoutStats: t -> Layout.t
 	    val profile: t -> t



1.31      +2 -1      mlton/mlton/ssa/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- type-check.fun	4 Apr 2004 06:50:21 -0000	1.30
+++ type-check.fun	12 Apr 2004 17:53:07 -0000	1.31
@@ -381,7 +381,8 @@
 	    val () =
 	       if Type.checkPrimApp {args = args,
 				     prim = prim,
-				     result = resultType}
+				     result = resultType,
+				     targs = targs}
 		  then ()
 	       else error ("bad primapp",
 			   let



1.15      +1 -1      mlton/mlton/xml/implement-exceptions.fun

Index: implement-exceptions.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/implement-exceptions.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- implement-exceptions.fun	3 Mar 2004 02:09:08 -0000	1.14
+++ implement-exceptions.fun	12 Apr 2004 17:53:08 -0000	1.15
@@ -54,7 +54,7 @@
 	    let
 	       val sumTycon = Tycon.newNoname ()
 	       val sumType = Type.con (sumTycon, Vector.new0 ())
-	       fun find (nameString: string, isName: Prim.Name.t -> bool)
+	       fun find (nameString: string, isName: Type.t Prim.Name.t -> bool)
 		  : Var.t * Type.t * PrimExp.t =
 		  let
 		     val var =



1.16      +4 -4      mlton/mlton/xml/monomorphise.fun

Index: monomorphise.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/monomorphise.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- monomorphise.fun	24 Feb 2004 02:28:07 -0000	1.15
+++ monomorphise.fun	12 Apr 2004 17:53:08 -0000	1.16
@@ -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.
  *
@@ -306,9 +306,9 @@
 				handler = monoExp handler}
 	  | XprimExp.Lambda l => SprimExp.Lambda (monoLambda l)
 	  | XprimExp.PrimApp {prim, targs, args} =>
-	       SprimExp.PrimApp {prim = prim,
-				 targs = monoTypes targs,
-				 args = monoVarExps args}
+	       SprimExp.PrimApp {args = monoVarExps args,
+				 prim = Prim.map (prim, monoType),
+				 targs = monoTypes targs}
 	  | XprimExp.Profile e => SprimExp.Profile  e
 	  | XprimExp.Raise {exn, filePos} =>
 	       SprimExp.Raise {exn = monoVarExp exn,



1.10      +1 -1      mlton/mlton/xml/simplify-types.fun

Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify-types.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- simplify-types.fun	18 Feb 2004 04:24:24 -0000	1.9
+++ simplify-types.fun	12 Apr 2004 17:53:08 -0000	1.10
@@ -272,7 +272,7 @@
 	  | I.PrimExp.Lambda l => O.PrimExp.Lambda (fixLambda l)
 	  | I.PrimExp.PrimApp {args, prim, targs} =>
 	       O.PrimExp.PrimApp {args = Vector.map (args, fixVarExp),
-				  prim = prim,
+				  prim = Prim.map (prim, fixType),
 				  targs = Vector.map (targs, fixType)}
 	  | I.PrimExp.Profile e => O.PrimExp.Profile e
 	  | I.PrimExp.Raise {exn, filePos} =>



1.17      +2 -1      mlton/mlton/xml/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/type-check.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- type-check.fun	4 Apr 2004 06:50:22 -0000	1.16
+++ type-check.fun	12 Apr 2004 17:53:08 -0000	1.17
@@ -229,7 +229,8 @@
 		     val () =
 			if Type.checkPrimApp {args = checkVarExps args,
 					      prim = prim,
-					      result = ty}
+					      result = ty,
+					      targs = targs}
 			   then ()
 			else error "bad primapp"
 		  in



1.20      +1 -1      mlton/mlton/xml/xml-tree.fun

Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- xml-tree.fun	18 Feb 2004 04:24:24 -0000	1.19
+++ xml-tree.fun	12 Apr 2004 17:53:08 -0000	1.20
@@ -174,7 +174,7 @@
 	       handler: exp}
   | Lambda of lambda
   | PrimApp of {args: VarExp.t vector,
-		prim: Prim.t,
+		prim: Type.t Prim.t,
 		targs: Type.t vector}
   | Profile of ProfileExp.t
   | Raise of {exn: VarExp.t,



1.14      +3 -3      mlton/mlton/xml/xml-tree.sig

Index: xml-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.sig,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- xml-tree.sig	9 Oct 2003 18:17:35 -0000	1.13
+++ xml-tree.sig	12 Apr 2004 17:53:08 -0000	1.14
@@ -103,7 +103,7 @@
 			  try: exp}
 	     | Lambda of Lambda.t
 	     | PrimApp of {args: VarExp.t vector,
-			   prim: Prim.t,
+			   prim: Type.t Prim.t,
 			   targs: Type.t vector}
 	     | Profile of ProfileExp.t
 	     | Raise of {exn: VarExp.t,
@@ -167,7 +167,7 @@
 	    val foreachPrimExp: t * (Var.t * Type.t * PrimExp.t -> unit) -> unit
 	    val foreachVarExp: t * (VarExp.t -> unit) -> unit
 	    val fromPrimExp: PrimExp.t * Type.t -> t
-	    val hasPrim: t * (Prim.t -> bool) -> bool
+	    val hasPrim: t * (Type.t Prim.t -> bool) -> bool
 	    val layout: t -> Layout.t
 	    val make: {decs: Dec.t list, result: VarExp.t} -> t
 	    val prefix: t * Dec.t -> t
@@ -211,7 +211,7 @@
 	    val lett: {decs: Dec.t list, body: t} -> t
 	    val monoVar: Var.t * Type.t -> t
 	    val primApp: {args: t vector,
-			  prim: Prim.t,
+			  prim: Type.t Prim.t,
 			  targs: Type.t vector,
 			  ty: Type.t} -> t
 	    val raisee: {exn: t, filePos: string option} * Type.t -> t