[MLton-devel] Callbacks
Matthew Fluet
fluet@cs.cornell.edu
Sat, 17 May 2003 15:40:33 -0400 (EDT)
Here is a proposal for a MLton.Callback structure to replace MLton.FFI.
On the ML side we have:
---------------------------------------------------------------------------
signature MLTON_CALLBACK =
sig
structure Type :
sig
type ('a, 'b) arg
type 'a res
val C: (char, 'b) arg
val B: (bool, 'b) arg
val I: (int, 'b) arg
val U: (unit, 'b) arg
val W: (word, 'b) arg
val --> : ('a, 'b) arg * 'b res -> ('a -> 'b) res
val C' : char res
val B' : bool res
val I' : int res
val U' : unit res
val W' : word res
end
val register: string * ('a -> 'b) Type.res -> ('a -> 'b) -> unit
val unregister: string -> unit
val isRegistered: string -> bool
end
---------------------------------------------------------------------------
The MLton.Callback.Type structure takes as inspiration the Printf example.
It serve two purposes. First, it provides a type-safe interface to
Callbacks, in the sense that a user will only be able to register a
function whose type is compatible with the callback mechanism. Second,
the value of type ('a -> 'b) Type.res is a _real_ value that builds up
auxilary functions for working with the callback mechanism behind the
scenes; i.e., ('a, 'b) Type.arg and 'b Type.res are _not_ phantom types
whose only purpose is type checking, although this is a case where phantom
types of that form would be applicable.
Example client code is as follows:
---------------------------------------------------------------------------
(* z.sml *)
val f = _ffi "f": unit -> unit;
val f = fn () =>
(print "calling f\n"
; f ()
; print "done calling f\n")
local
open MLton.Callback
open Type
infixr -->
in
val _ =
register ("A", I --> I --> I')
(fn i => fn j =>
let val r = i + j in
print (concat ["A(", Int.toString i,
",", Int.toString j,
") = ", Int.toString r, "\n"])
; r
end)
val _ =
register ("B", I --> I --> I')
(fn i => fn j =>
let val r = i * j in
print (concat ["B(", Int.toString i,
",", Int.toString j,
") = ", Int.toString r, "\n"])
; r
end)
end
val _ = f ()
---------------------------------------------------------------------------
---------------------------------------------------------------------------
/* f.c */
#include <stdio.h>
#include <mlton-basis.h>
void f () {
int x;
fprintf (stderr, "f calling SML: A(1,2)\n");
MLton_Callback_setI(0, 1);
MLton_Callback_setI(1, 2);
MLton_Callback_call("A");
x = MLton_Callback_getI();
fprintf (stderr, "f done calling SML: A(1,2) = %i\n", x);
fprintf (stderr, "f calling SML: B(1,2)\n");
MLton_Callback_setI(0, 1);
MLton_Callback_setI(1, 2);
MLton_Callback_call("B");
x = MLton_Callback_getI();
fprintf (stderr, "f done calling SML: B(1,2) = %i\n", x);
}
---------------------------------------------------------------------------
Compiling and running yields:
[fluet@localhost test]$ mlton.cvs.HEAD z.sml f.c
[fluet@localhost test]$ ./z
calling f
f calling SML: A(1,2)
A(1,2) = 3
f done calling SML: A(1,2) = 3
f calling SML: B(1,2)
B(1,2) = 2
f done calling SML: B(1,2) = 2
done calling f
Some work could be done on the C-side, as the set-up and execution of an
ML call is a little burdensome. Furthermore, implementation details leak
through. As can probably be ascertained from the C-code above, the
implementation is essentially a collection of global locations used to
pass parameters back and forth between C and ML. On the C-side, we set up
the arguments with
MLton_Callback_setI(index, arg);
make a call with
MLton_Callback_call(name);
and fetch return results with
MLton_Callback_getI();
We could either provide a collection of common calls or maybe it's
possible to use varargs to get a general solution.
On the ML-side, we have a collection of _ffi primitives:
---------------------------------------------------------------------------
(* basis-library/misc/primitive.sml *)
structure Callback =
struct
val fetchI = _ffi "MLton_Callback_fetchI": int -> int;
val retI = _ffi "MLton_Callback_retI": int -> unit;
val callbackName = _ffi "MLton_Callback_callbackName": unit -> cstring;
end
---------------------------------------------------------------------------
For the time being, I've elected to go with really trivial registration;
obviously, we could use fancier datastructures for faster lookups.
---------------------------------------------------------------------------
(* basis-library/mlton/callback.sml
structure MLtonCallback :> MLTON_CALLBACK_EXTRA =
struct
structure Prim = Primitive.MLton.Callback
structure Type =
struct ... end
val registered : (string * (unit -> unit)) list ref = ref []
fun pred n = (fn (n',_) => n = n')
fun isRegistered n =
List.exists (pred n) (!registered)
fun unregister n =
registered := List.filter (not o (pred n)) (!registered)
val register' =
let
val _ =
MLtonThread.setCallFromCHandler
(false,
fn () =>
let
val cs = Prim.callbackName ()
val n = if Primitive.Cpointer.isNull cs
then raise Fail ("null callback function")
else C.CS.toString cs
in
case List.find (pred n) (!registered) of
SOME (_,f) => f ()
| NONE => raise Fail ("unregistered callback function: " ^ n)
end)
in
fn (n,f) =>
(unregister n
; registered := (n,f)::(!registered))
end
fun register (n,ty) f =
register' (n, Type.make ty f)
end
---------------------------------------------------------------------------
This portion of the implementation is straightforward; the
CallFromCHandler is set to a function that fetches the requested function
name, looks it up in the list of registered functions, and executes it.
I've added a boolean argument to MLtonThread.setCallFromCHandler; when
false, setCallFromCHandler won't leave the critical section entered by the
MLton_callFromC. This is important here, because in order to make
callbacks thread-safe, we must fetch all the C-side arguments _before_
leaving the critical section (else, some other thread might start running,
enter C, and callback, clobbering our arguments). Likewise, we need to
enter a critical section when returning a result to C. Therefore, I've
modified the MLton_callFromC functions to leave a critical section after
the call to SML returns. MLtonThread.setCallFromCHandler inserts a call
to atomicBegin before Thread_returnToC, unless the installed handler
requests to handle the critical sections itself.
You can see that a lot of burden falls on Callback.Type. The function
val Type.make : ('a, 'b) Type.res -> ('a -> 'b) -> (unit -> unit)
takes a type description, a function, and returns a unit -> unit function
that fetches all the C-side arguments, leaves the critical section,
executes the function on the fetched arguments, enters a critical section,
and sets the C-side return value.
Here is the solution I came up with:
---------------------------------------------------------------------------
structure Type =
struct
type indices = int vector
local
val numIndices : int = 4
val indexB : int = 0
val indexC : int = 1
val indexI : int = 2
val indexW : int = 3
fun mkFetchInc (fetch, i) =
(fn (z:indices) =>
fetch (Vector.sub (z,i)),
fn (z:indices) =>
Vector.tabulate(numIndices,
fn j => let val v = Vector.sub (z,j)
in if i = j then v + 1 else v
end))
in
val (fetchI,incI) = mkFetchInc (Prim.fetchI, indexI)
val retI = Prim.retI
val zeroIndices : indices =
Vector.tabulate(numIndices, fn _ => 0)
end
type ('a, 'b) arg =
indices -> (('a -> 'b) -> (unit -> (unit -> 'b))) * indices
type 'b res =
indices -> ((unit -> 'b) -> (unit -> (unit -> unit)))
val I : (int, 'b) arg =
fn (z:indices) =>
(fn f => fn () =>
let val i = fetchI z
in fn () => f i end,
incI z)
infixr -->
fun (X: ('a, 'b) arg) --> (Y: 'b res) : ('a -> 'b) res =
fn (z:indices) =>
let
val (X: ('a -> 'b) -> (unit -> (unit -> 'b)), z:indices) = X z
in
fn (F : unit -> ('a -> 'b)) =>
let
val f: unit -> (unit -> 'b) = X (F ())
in
fn () =>
Y z (f ()) ()
end
end
val I' : int res =
fn (z:indices) =>
fn f => fn () => fn () =>
let val v = f () in
MLtonThread.atomicBegin ()
; retI v
end
fun make (ty: ('a -> 'b) res) : ('a -> 'b) -> (unit -> unit) =
fn (f: 'a -> 'b) =>
let val f = ty zeroIndices (fn () => f) in
fn () =>
let val f = f () in
MLtonThread.atomicEnd ()
; f ()
end
end
end
---------------------------------------------------------------------------
The missing Type.arg and Type.res values are all similar to I and I'; just
change the fetch?, inc?, and ret? functions. Thunks are used like mad to
keep the real function suspended while we fetch all the C-side arguments,
pause for an atomicEnd (), and then run the function composed with an
atomicBegin () and setting the C-side return. We track the C-side
arguments with an int vector, where the appopriate slot is incremented
each time we encounter an argument. A tuple would work equally well,
which is why I've purposely left the indices type fairly abstract after
defining all the fetch? and inc? functions. Adding a new type and/or
changing the indices representation should be very straightforward.
The make function seeds the type with the all zero indices and an
suspended function. Then the Type.arg and Type.res values and --> take
over to build the right function.
Thoughts? Comments?
-------------------------------------------------------
This SF.net email is sponsored by: If flattening out C++ or Java
code to make your application fit in a relational database is painful,
don't do it! Check out ObjectStore. Now part of Progress Software.
http://www.objectstore.net/sourceforge
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel