[MLton] cvs commit: MLton.FFI now uses MLton.Pointer

sweeks@mlton.org sweeks@mlton.org
Mon, 1 Dec 2003 19:59:08 -0800


sweeks      03/12/01 19:59:08

  Modified:    basis-library/misc primitive.sml
               basis-library/mlton ffi.sig ffi.sml pointer.sig
               mlton/atoms ffi.fun prim.fun prim.sig
               mlton/backend ssa-to-rssa.fun
  Log:
  MAIL MLton.FFI now uses MLton.Pointer
  
  Implemented the parameter passing for MLton.FFI using MLton.Pointer to
  get/set array elements, thus eliminating the family of FFI primitives
  that was used for array access.
  
  Added MLton.Pointer.{get,set}Pointer, which allows one to get/set a
  pointer.  The primitives are polymorphic so that we can use them to
  access all kinds of values that are pointers (including arrays,
  strings, and MLton.Pointer.t).  But for now, the signature only
  exports them at MLton.Pointer.t.
  
  One thing to keep in mind, and a mistake that I have now made twice
  while working on the pointer stuff, is that a C array is *not* a
  pointer.  That is, if in C you have
  
  	int a[13];
  
  Then it is *not* correct to do in SML
  
  	val a = _import "a": MLton.Pointer.t;
          val _ = MLton.Pointer.getInt32 (a, 5)
  
  Instead you must do in C
  
  	int a[13];
  	int *aPtr = &a;
  
  followed by the SML
  
  	val a = _import "aPtr": MLton.Pointer.t;
          val _ = MLton.Pointer.getInt32 (a, 5)

Revision  Changes    Path
1.89      +14 -19    mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.88
retrieving revision 1.89
diff -u -r1.88 -r1.89
--- primitive.sml	1 Dec 2003 18:22:17 -0000	1.88
+++ primitive.sml	2 Dec 2003 03:59:07 -0000	1.89
@@ -259,26 +259,19 @@
 
       structure FFI =
 	 struct
-	    val getInt8 = _import "MLton_FFI_getInt8": int -> Int8.int;
-	    val getInt16 = _import "MLton_FFI_getInt16": int -> Int16.int;
-	    val getInt32 = _import "MLton_FFI_getInt32": int -> Int32.int;
-	    val getInt64 = _import "MLton_FFI_getInt64": int -> Int64.int;
-	    val getOp = _import "MLton_FFI_getOp": unit -> int;
-	    val getReal32 = _import "MLton_FFI_getReal32": int -> Real32.real;
-	    val getReal64 = _import "MLton_FFI_getReal64": int -> Real64.real;
-	    val getWord8 = _import "MLton_FFI_getWord8": int -> Word8.word;
-	    val getWord16 = _import "MLton_FFI_getWord16": int -> Word16.word;
-	    val getWord32 = _import "MLton_FFI_getWord32": int -> Word32.word;
+	    val int8Array = _import "MLton_FFI_Int8": Pointer.t;
+	    val int16Array = _import "MLton_FFI_Int16": Pointer.t;
+	    val int32Array = _import "MLton_FFI_Int32": Pointer.t;
+	    val int64Array = _import "MLton_FFI_Int64": Pointer.t;
+	    val getOp = fn () => _import "MLton_FFI_op": int;
 	    val numExports = _build_const "MLton_FFI_numExports": int;
-	    val setInt8 = _import "MLton_FFI_setInt8": Int8.int -> unit;
-	    val setInt16 = _import "MLton_FFI_setInt16": Int16.int -> unit;
-	    val setInt32 = _import "MLton_FFI_setInt32": Int32.int -> unit;
-	    val setInt64 = _import "MLton_FFI_setInt64": Int64.int -> unit;
-	    val setReal32 = _import "MLton_FFI_setReal32": Real32.real -> unit;
-	    val setReal64 = _import "MLton_FFI_setReal64": Real64.real -> unit;
-  	    val setWord8 = _import "MLton_FFI_setWord8": Word8.word -> unit;
-	    val setWord16 = _import "MLton_FFI_setWord16": Word16.word -> unit;
-	    val setWord32 = _import "MLton_FFI_setWord32": Word32.word -> unit;
+	    val pointerArray = _import "MLton_FFI_Pointer": Pointer.t;
+	    val real32Array = _import "MLton_FFI_Real32": Pointer.t;
+	    val real64Array = _import "MLton_FFI_Real64": Pointer.t;
+	    val word8Array = _import "MLton_FFI_Word8": Pointer.t;
+	    val word16Array = _import "MLton_FFI_Word16": Pointer.t;
+	    val word32Array = _import "MLton_FFI_Word32": Pointer.t;
+	    val word64Array = _import "MLton_FFI_Word64": Pointer.t;
 	 end
 
       structure GC =
@@ -730,6 +723,7 @@
 	    val getInt16 = _prim "Pointer_getInt16": t * int -> Int16.int;
 	    val getInt32 = _prim "Pointer_getInt32": t * int -> Int32.int;
 	    val getInt64 = _prim "Pointer_getInt64": t * int -> Int64.int;
+	    val getPointer = _prim "Pointer_getPointer": t * int -> 'a;
 	    val getReal32 = _prim "Pointer_getReal32": t * int -> Real32.real;
 	    val getReal64 = _prim "Pointer_getReal64": t * int -> Real64.real;
 	    val getWord8 = _prim "Pointer_getWord8": t * int -> Word8.word;
@@ -740,6 +734,7 @@
 	    val setInt16 = _prim "Pointer_setInt16": t * int * Int16.int -> unit;
 	    val setInt32 = _prim "Pointer_setInt32": t * int * Int32.int -> unit;
 	    val setInt64 = _prim "Pointer_setInt64": t * int * Int64.int -> unit;
+	    val setPointer = _prim "Pointer_setPointer": t * int * 'a -> unit;
 	    val setReal32 =
 	       _prim "Pointer_setReal32": t * int * Real32.real -> unit;
 	    val setReal64 =



1.4       +4 -0      mlton/basis-library/mlton/ffi.sig

Index: ffi.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/ffi.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ffi.sig	1 Dec 2003 18:22:17 -0000	1.3
+++ ffi.sig	2 Dec 2003 03:59:07 -0000	1.4
@@ -8,11 +8,13 @@
       val getInt16: int -> Int16.int
       val getInt32: int -> Int32.int
       val getInt64: int -> Int64.int
+      val getPointer: int -> 'a
       val getReal32: int -> Real32.real
       val getReal64: int -> Real64.real
       val getWord8: int -> Word8.word
       val getWord16: int -> Word16.word
       val getWord32: int -> Word32.word
+      val getWord64: int -> Word64.word
       val register: int * (unit -> unit) -> unit
       val setBool: bool -> unit
       val setChar: char -> unit
@@ -20,9 +22,11 @@
       val setInt16: Int16.int -> unit
       val setInt32: Int32.int -> unit
       val setInt64: Int64.int -> unit
+      val setPointer: 'a -> unit
       val setReal32: Real32.real -> unit
       val setReal64: Real64.real -> unit
       val setWord8: Word8.word -> unit
       val setWord16: Word16.word -> unit
       val setWord32: Word32.word -> unit
+      val setWord64: Word64.word -> unit
    end



1.8       +29 -1     mlton/basis-library/mlton/ffi.sml

Index: ffi.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/ffi.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- ffi.sml	20 Jul 2003 18:07:58 -0000	1.7
+++ ffi.sml	2 Dec 2003 03:59:07 -0000	1.8
@@ -3,7 +3,35 @@
 
 structure Prim = Primitive.FFI
 
-open Prim
+structure Pointer = Primitive.Pointer
+
+local
+   fun make (p: Pointer.t, get, set) =
+      (fn i => get (p, i), fn x => set (p, 0, x))
+in
+   val (getInt8, setInt8) =
+      make (Prim.int8Array, Pointer.getInt8, Pointer.setInt8)
+   val (getInt16, setInt16) =
+      make (Prim.int16Array, Pointer.getInt16, Pointer.setInt16)
+   val (getInt32, setInt32) =
+      make (Prim.int32Array, Pointer.getInt32, Pointer.setInt32)
+   val (getInt64, setInt64) =
+      make (Prim.int64Array, Pointer.getInt64, Pointer.setInt64)
+   fun getPointer i = Pointer.getPointer (Prim.pointerArray, i)
+   fun setPointer x = Pointer.setPointer (Prim.pointerArray, 0, x)
+   val (getReal32, setReal32) =
+      make (Prim.real32Array, Pointer.getReal32, Pointer.setReal32)
+   val (getReal64, setReal64) =
+      make (Prim.real64Array, Pointer.getReal64, Pointer.setReal64)
+   val (getWord8, setWord8) =
+      make (Prim.word8Array, Pointer.getWord8, Pointer.setWord8)
+   val (getWord16, setWord16) =
+      make (Prim.word16Array, Pointer.getWord16, Pointer.setWord16)
+   val (getWord32, setWord32) =
+      make (Prim.word32Array, Pointer.getWord32, Pointer.setWord32)
+   val (getWord64, setWord64) =
+      make (Prim.word64Array, Pointer.getWord64, Pointer.setWord64)
+end
 
 val atomicBegin = MLtonThread.atomicBegin
 val atomicEnd = MLtonThread.atomicEnd



1.2       +2 -0      mlton/basis-library/mlton/pointer.sig

Index: pointer.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/pointer.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- pointer.sig	1 Dec 2003 18:22:17 -0000	1.1
+++ pointer.sig	2 Dec 2003 03:59:07 -0000	1.2
@@ -8,6 +8,7 @@
       val getInt16: t * int -> Int16.int
       val getInt32: t * int -> Int32.int
       val getInt64: t * int -> Int64.int
+      val getPointer: t * int -> t
       val getReal32: t * int -> Real32.real
       val getReal64: t * int -> Real64.real
       val getWord8: t * int -> Word8.word
@@ -20,6 +21,7 @@
       val setInt16: t * int * Int16.int -> unit
       val setInt32: t * int * Int32.int -> unit
       val setInt64: t * int * Int64.int -> unit
+      val setPointer: t * int * t -> unit
       val setReal32: t * int * Real32.real -> unit
       val setReal64: t * int * Real64.real -> unit
       val setWord8: t * int * Word8.word -> unit



1.6       +6 -14     mlton/mlton/atoms/ffi.fun

Index: ffi.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- ffi.fun	20 Jul 2003 17:45:35 -0000	1.5
+++ ffi.fun	2 Dec 2003 03:59:07 -0000	1.6
@@ -61,22 +61,14 @@
 		   let
 		      val size = Int.toString (1 + n)
 		      val t = CType.toString t
+		      val array = concat ["MLton_FFI_", t, "_array"]
 		   in
-		      print (concat [t, " MLton_FFI_", t, "[", size, "];\n"])
-		      ; print (concat [t, " MLton_FFI_get", t, " (Int i) {\n",
-				       "\treturn MLton_FFI_", t, "[i];\n",
-				       "}\n"])
-		      ; print (concat
-			       [t, " MLton_FFI_set", t, " (", t, " x) {\n",
-				"\tMLton_FFI_", t, "[0] = x;\n",
-				"}\n"])
+		      print (concat [t, " ", array, "[", size, "];\n",
+				     t, " *MLton_FFI_", t, " = &", array, ";\n"])
 		   end
 	     else ()
 	  end)
       val _ = print "Int MLton_FFI_op;\n"
-      val _ = print (concat ["Int MLton_FFI_getOp () {\n",
-			     "\treturn MLton_FFI_op;\n",
-			     "}\n"])
    in
       List.foreach
       (!exports, fn {args, convention, id, name, res} =>
@@ -93,8 +85,8 @@
 	      in
 		 (x,
 		  concat [t, " ", x],
-		  concat ["\tMLton_FFI_", t, "[", Int.toString index, "] = ",
-			  x, ";\n"])
+		  concat ["\tMLton_FFI_", t, "_array[", Int.toString index,
+			  "] = ", x, ";\n"])
 	      end)
 	  val header =
 	     concat [case res of
@@ -118,7 +110,7 @@
 		NONE => ()
 	      | SOME t =>
 		   print (concat
-			  ["\treturn MLton_FFI_", CType.toString t, "[0];\n"]))
+			  ["\treturn MLton_FFI_", CType.toString t, "_array[0];\n"]))
 	  ; print "}\n"
        end)
    end



1.67      +7 -0      mlton/mlton/atoms/prim.fun

Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- prim.fun	1 Dec 2003 18:22:18 -0000	1.66
+++ prim.fun	2 Dec 2003 03:59:07 -0000	1.67
@@ -121,9 +121,11 @@
        | 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 *)
        | Real_Math_acos of RealSize.t (* codegen *)
@@ -447,6 +449,9 @@
 	  in
 	     List.concat [doit ("Int", IntSize.all, IntSize.toString,
 				Pointer_getInt, Pointer_setInt),
+			  doit ("Pointer", [()], fn () => "",
+				fn () => Pointer_getPointer,
+				fn () => Pointer_setPointer),
 			  doit ("Real", RealSize.all, RealSize.toString,
 				Pointer_getReal, Pointer_setReal),
 			  doit ("Word", WordSize.all, WordSize.toString,
@@ -629,6 +634,8 @@
        | MLton_serialize => one (arg 0)
        | MLton_size => one (deRef (arg 0))
        | MLton_touch => one (arg 0)
+       | Pointer_getPointer => one result
+       | Pointer_setPointer => one (arg 2)
        | Ref_assign => one (arg 1)
        | Ref_deref => one result
        | Ref_ref => one (arg 0)



1.51      +2 -0      mlton/mlton/atoms/prim.sig

Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- prim.sig	1 Dec 2003 18:22:18 -0000	1.50
+++ prim.sig	2 Dec 2003 03:59:07 -0000	1.51
@@ -112,9 +112,11 @@
 	     | 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 *)
 	     | Real_Math_acos of RealSize.t (* codegen *)



1.53      +8 -10     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.52
retrieving revision 1.53
diff -u -r1.52 -r1.53
--- ssa-to-rssa.fun	1 Dec 2003 18:22:20 -0000	1.52
+++ ssa-to-rssa.fun	2 Dec 2003 03:59:08 -0000	1.53
@@ -184,16 +184,6 @@
 				 name = "Word64_equal",
 				 return = SOME CType.defaultInt}
 
-      val getPointer =
-	 vanilla {args = Vector.new1 Int32,
-		  name = "MLton_FFI_getPointer",
-		  return = SOME Pointer}
-
-      val setPointer =
-	 vanilla {args = Vector.new1 Pointer,
-		  name = "MLton_FFI_setPointer",
-		  return = NONE}
-
       val copyCurrentThread =
 	 T {args = Vector.new1 Pointer,
 	    bytesNeeded = NONE,
@@ -1318,9 +1308,17 @@
 				      | SOME _ => normal ())
 			       | MLton_size => simpleCCall CFunction.size
 			       | Pointer_getInt s => pointerGet (Type.Int s)
+			       | Pointer_getPointer =>
+				    (case targ () of
+					NONE => Error.bug "getPointer"
+				      | SOME t => pointerGet t)
 			       | Pointer_getReal s => pointerGet (Type.Real s)
 			       | Pointer_getWord s => pointerGet (Type.Word s)
 			       | Pointer_setInt s => pointerSet (Type.Int s)
+			       | Pointer_setPointer =>
+				    (case targ () of
+					NONE => Error.bug "setPointer"
+				      | SOME t => pointerSet t)
 			       | Pointer_setReal s => pointerSet (Type.Real s)
 			       | Pointer_setWord s => pointerSet (Type.Word s)
 			       | Ref_assign =>