[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