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