[MLton-devel] cvs commit: Callbacks

Matthew Fluet fluet@users.sourceforge.net
Thu, 19 Jun 2003 08:38:05 -0700


fluet       03/06/19 08:38:04

  Modified:    basis-library/libs build
               basis-library/libs/basis-2002/top-level top-level.sml
               basis-library/misc primitive.sml
               basis-library/mlton ffi.sml mlton.sig mlton.sml thread.sig
                        thread.sml
               include  c-main.h x86-main.h
               runtime  Makefile mlton-basis.h
  Added:       basis-library/mlton callback.sig callback.sml
               runtime/basis/MLton Callback.c
  Log:
  Implementation of a Callback mechanism for MLton.  The implementation
  utilized the MLton.FFI.handleCallFromC function to install a handler
  to dispatch on C side calls to SML.  Additional design information is
  available in the mlton-devel mailing list archive (May 19 post).

Revision  Changes    Path
1.15      +2 -0      mlton/basis-library/libs/build

Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- build	15 May 2003 20:12:26 -0000	1.14
+++ build	19 Jun 2003 15:38:03 -0000	1.15
@@ -185,6 +185,8 @@
 net/unix-sock.sml
 
 mlton/array.sig
+mlton/callback.sig
+mlton/callback.sml
 mlton/cont.sig
 mlton/cont.sml
 mlton/random.sig



1.4       +1 -0      mlton/basis-library/libs/basis-2002/top-level/top-level.sml

Index: top-level.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/top-level.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- top-level.sml	15 May 2003 19:08:15 -0000	1.3
+++ top-level.sml	19 Jun 2003 15:38:04 -0000	1.4
@@ -9,6 +9,7 @@
 (* Non-standard signatures *)
 signature MLTON_ARRAY = MLTON_ARRAY
 signature MLTON_BIN_IO = MLTON_BIN_IO
+signature MLTON_CALLBACK = MLTON_CALLBACK
 signature MLTON_CONT = MLTON_CONT
 signature MLTON_EXN = MLTON_EXN
 signature MLTON_FFI = MLTON_FFI



1.55      +16 -0     mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- primitive.sml	5 Jun 2003 22:57:13 -0000	1.54
+++ primitive.sml	19 Jun 2003 15:38:04 -0000	1.55
@@ -296,6 +296,22 @@
 (*       val serialize = _prim "MLton_serialize": 'a ref -> Word8Vector.vector; *)
 	    val size = fn x => _prim "MLton_size": 'a ref -> int; x
 
+	    structure Callback =
+	       struct
+		  val fetchB = _ffi "MLton_Callback_fetchB": int -> bool;
+		  val fetchC = _ffi "MLton_Callback_fetchC": int -> char;
+		  val fetchI = _ffi "MLton_Callback_fetchI": int -> int;
+		  val fetchR = _ffi "MLton_Callback_fetchR": int -> real;
+		  val fetchW = _ffi "MLton_Callback_fetchW": int -> word;
+		  val retB = _ffi "MLton_Callback_retB":  bool -> unit;
+		  val retC = _ffi "MLton_Callback_retC": char -> unit;
+		  val retI = _ffi "MLton_Callback_retI": int -> unit;
+		  val retR = _ffi "MLton_Callback_retR": real -> unit;
+		  val retW = _ffi "MLton_Callback_retW": word -> unit;
+		  val callbackName = _ffi "MLton_Callback_callbackName": unit -> cstring;
+		  val callbackType = _ffi "MLton_Callback_callbackType": unit -> cstring;
+	       end
+
 	    structure Platform =
 	       struct
 		  datatype arch = Sparc | X86



1.2       +1 -1      mlton/basis-library/mlton/ffi.sml

Index: ffi.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/ffi.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- ffi.sml	25 Mar 2003 04:31:22 -0000	1.1
+++ ffi.sml	19 Jun 2003 15:38:04 -0000	1.2
@@ -1,6 +1,6 @@
 structure MLtonFFI =
 struct
 
-val handleCallFromC = MLtonThread.setCallFromCHandler
+val handleCallFromC = fn f => MLtonThread.setCallFromCHandler (true, f)
    
 end



1.25      +2 -1      mlton/basis-library/mlton/mlton.sig

Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sig,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- mlton.sig	20 May 2003 17:06:00 -0000	1.24
+++ mlton.sig	19 Jun 2003 15:38:04 -0000	1.25
@@ -26,10 +26,11 @@
 
       structure Array: MLTON_ARRAY
       structure BinIO: MLTON_BIN_IO
+      structure Callback: MLTON_CALLBACK
       structure Cont: MLTON_CONT
       structure Exn: MLTON_EXN
-      structure Finalizable: MLTON_FINALIZABLE
       structure FFI: MLTON_FFI
+      structure Finalizable: MLTON_FINALIZABLE
       structure GC: MLTON_GC
       structure IntInf: MLTON_INT_INF
       structure Itimer: MLTON_ITIMER



1.24      +2 -1      mlton/basis-library/mlton/mlton.sml

Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sml,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- mlton.sml	20 May 2003 17:06:00 -0000	1.23
+++ mlton.sml	19 Jun 2003 15:38:04 -0000	1.24
@@ -48,10 +48,11 @@
 	 val stdOut = stdOut
       end
    end
+structure Callback = MLtonCallback
 structure Cont = MLtonCont
 structure Exn = MLtonExn
-structure Finalizable = MLtonFinalizable
 structure FFI = MLtonFFI
+structure Finalizable = MLtonFinalizable
 structure GC = MLtonGC
 structure IntInf = IntInf
 structure Itimer = MLtonItimer



1.6       +1 -1      mlton/basis-library/mlton/thread.sig

Index: thread.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- thread.sig	25 Mar 2003 04:31:23 -0000	1.5
+++ thread.sig	19 Jun 2003 15:38:04 -0000	1.6
@@ -32,7 +32,7 @@
       include MLTON_THREAD
 
       val amInSignalHandler: unit -> bool
-      val setCallFromCHandler: (unit -> unit) -> unit
+      val setCallFromCHandler: (bool * (unit -> unit)) -> unit
       val setHandler: (unit t -> unit t) -> unit
       val switchToHandler: unit -> unit
    end



1.19      +11 -7     mlton/basis-library/mlton/thread.sml

Index: thread.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sml,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- thread.sml	16 May 2003 23:44:56 -0000	1.18
+++ thread.sml	19 Jun 2003 15:38:04 -0000	1.19
@@ -149,8 +149,8 @@
    
 val setCallFromCHandler =
    let
-      val r: (unit -> unit) ref =
-	 ref (fn () => raise Fail "no handler for C calls")
+      val r: (bool * (unit -> unit)) ref =
+	 ref (true, fn () => raise Fail "no handler for C calls")
       val _ =
 	 Prim.setCallFromCHandler
 	 (toPrimitive
@@ -161,10 +161,14 @@
 			 val _ =
 			    Prim.switchTo
 			    (toPrimitive
-			     (new (fn () => (atomicEnd ()
-					     ; !r ()
-					     ; Prim.setSaved t
-					     ; Prim.returnToC ()))))
+			     (new (fn () => 
+				   let val (b,f) = !r in
+				     if b then atomicEnd () else ()
+				     ; f ()
+				     ; Prim.setSaved t
+				     ; if b then atomicBegin () else ()
+				     ; Prim.returnToC ()
+				   end)))
 		      in
 			 loop ()
 		      end
@@ -172,7 +176,7 @@
 		   loop
 		end)))
    in
-      fn f => r := f
+      fn (b, f) => r := (b, f)
    end
 
 fun switchToHandler () =



1.1                  mlton/basis-library/mlton/callback.sig

Index: callback.sig
===================================================================
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 R: (real, '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 R': real 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

signature MLTON_CALLBACK_EXTRA =
  sig
    include MLTON_CALLBACK
  end


1.1                  mlton/basis-library/mlton/callback.sml

Index: callback.sml
===================================================================
structure MLtonCallback :> MLTON_CALLBACK_EXTRA =
  struct
    structure Prim = Primitive.MLton.Callback

    structure Type =
      struct
	type rep = char list	
	val zeroRep = []

	type 'a inc = rep -> rep
	type 'a fetch = rep -> 'a
	type 'a ret = 'a -> unit
	type 'a IF = ('a inc) * ('a fetch) 
	type 'a IFR = ('a inc) * ('a fetch) * ('a ret)
	fun ifrInc (inc,fetch,ret) = inc
	fun ifrFetch (inc,fetch,ret) = fetch
	fun ifrRet (inc,fetch,ret) = ret
	local
	  fun mkFetchIncRet
	      (name: char,
	       fetch: int -> 'a,
	       ret: 'a -> unit) : 'a IFR =
	    (fn rep => name::rep,
	     fn rep => 
	     fetch (List.foldl
		    (fn (c, index) => if c = name
					then index + 1
					else index)
		    0 rep),
	     ret)
	in
	  val ifrB : bool IFR = mkFetchIncRet (#"B", Prim.fetchB, Prim.retB)
	  val ifrC : char IFR = mkFetchIncRet (#"C", Prim.fetchC, Prim.retC)
	  val ifrI : int IFR = mkFetchIncRet (#"I", Prim.fetchI, Prim.retI)
	  val ifrR : real IFR = mkFetchIncRet (#"R", Prim.fetchR, Prim.retR)
	  val ifrU : unit IFR = mkFetchIncRet (#"U", fn i => (), fn () => ())
	  val ifrW : word IFR = mkFetchIncRet (#"W", Prim.fetchW, Prim.retW)
	end

	type 'b paused = unit -> (unit -> 'b)
	type ('a, 'b) ppaused = 'a -> 'b paused
	type ('a, 'b) arg = rep -> rep * ('a -> 'b, 'b) ppaused
	type 'b res = rep -> rep * (unit -> 'b, unit) ppaused

	local
	  fun make (inc: 'a inc, fetch: 'a fetch) : ('a, 'b) arg =
	    fn (rep: rep) =>
	    (inc rep,
	     fn f => fn () =>
	     let val b = fetch rep
	     in fn () => f b end)
	  fun mk (ifr: 'a IFR) =
	    make (ifrInc ifr, ifrFetch ifr)
	in
	  val B : (bool, 'b) arg = fn rep => mk ifrB rep
	  val C : (char, 'b) arg = fn rep => mk ifrC rep
	  val I : (int, 'b) arg = fn rep => mk ifrI rep
	  val R : (real, 'b) arg = fn rep => mk ifrR rep
 	  val U : (unit, 'b) arg = fn rep => mk ifrU rep
	  val W : (word, 'b) arg = fn rep => mk ifrW rep
	end

	infixr -->
	fun (X: ('a, 'b) arg) --> (Y: 'b res) : ('a -> 'b) res =
	  fn (rep: rep) =>
	  let 
	    val (rep: rep, X: ('a -> 'b, 'b) ppaused) = X rep
	    val (rep: rep, Y: (unit -> 'b, unit) ppaused) = Y rep
	  in
	    (rep,
	     fn (F : unit -> ('a -> 'b)) =>
	     let 
	       val f: 'b paused = X (F ())
	     in 
	       fn () => 
	       Y (f ()) ()
	     end)
	  end
	
	local
	  fun make' (inc: 'a inc, ret: 'a ret) : 'a res = 
	    fn (rep: rep) =>
	    (inc rep,
	     fn f => fn () => fn () =>
	     let val v = f () in
	       MLtonThread.atomicBegin ()
	       ; ret v
	     end)
	  fun mk' (ifr: 'a IFR) =
	    make' (ifrInc ifr, ifrRet ifr)
	in
	  val B' : bool res = mk' ifrB
	  val C' : char res = mk' ifrC
	  val I' : int res = mk' ifrI
	  val R' : real res = mk' ifrR
	  val U' : unit res = mk' ifrU
	  val W' : word res = mk' ifrW
	end
	  
	fun make (ty: ('a -> 'b) res) : ('a -> 'b) -> ((unit -> unit) * string) = 
	  fn (f: 'a -> 'b) =>
	  let 
	    val (rep: rep, ppaused: (unit -> 'a -> 'b, unit) ppaused) = 
	      ty zeroRep
	    val f = ppaused (fn () => f) 
	  in
	    (fn () =>
	     let val f = f () in
	       MLtonThread.atomicEnd ()
	       ; f ()
	     end,
	     implode (rev rep))
	  end
      end

    val registered : (string * ((unit -> unit) * string)) list ref = ref []

    fun pred (n:string) = (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
	     val cs = Prim.callbackType ()
	     val ty = if Primitive.Cpointer.isNull  cs
			then raise Fail ("null callback type")
			else C.CS.toString cs
	   in
	     case List.find (pred n) (!registered) of
	       SOME (_,(f,rep)) => 
		 if rep = ty
		   then f ()
		   else raise Fail ("callback function type mismatch: " ^ n)
	     | NONE => raise Fail ("unregistered callback function: " ^ n)
	   end)
      in
	fn (n,frep) => 
	(unregister n
	 ; registered := (n,frep)::(!registered))
      end
    fun register (n,ty) f =
      register' (n, Type.make ty f)
  end



1.4       +1 -0      mlton/include/c-main.h

Index: c-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-main.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- c-main.h	16 May 2003 23:44:55 -0000	1.3
+++ c-main.h	19 Jun 2003 15:38:04 -0000	1.4
@@ -31,6 +31,7 @@
  		cont=(*(struct cont(*)(void))cont.nextChunk)();			\
 	} while (not returnToC);						\
 	GC_switchToThread (s, s->savedThread);					\
+	s->canHandle--;								\
 	s->savedThread = BOGUS_THREAD;						\
 	if (DEBUG_CCODEGEN)							\
 		fprintf (stderr, "MLton_callFromC done\n");			\



1.4       +1 -0      mlton/include/x86-main.h

Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- x86-main.h	16 May 2003 23:44:55 -0000	1.3
+++ x86-main.h	19 Jun 2003 15:38:04 -0000	1.4
@@ -84,6 +84,7 @@
 	jump = *(pointer*)(s->stackTop - WORD_SIZE);			\
 	MLton_jumpToSML(jump);						\
 	GC_switchToThread (s, s->savedThread);				\
+	s->canHandle--;							\
 	s->savedThread = BOGUS_THREAD;					\
 	if (DEBUG_X86CODEGEN)						\
 		fprintf (stderr, "MLton_callFromC() done\n");		\



1.63      +2 -0      mlton/runtime/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -r1.62 -r1.63
--- Makefile	3 Jun 2003 20:05:51 -0000	1.62
+++ Makefile	19 Jun 2003 15:38:04 -0000	1.63
@@ -41,6 +41,7 @@
 	basis/Itimer/set.o			\
 	basis/MLton/allocTooLarge.o		\
 	basis/MLton/bug.o			\
+	basis/MLton/Callback.o			\
 	basis/MLton/errno.o			\
 	basis/MLton/exit.o			\
 	basis/MLton/profile.o			\
@@ -211,6 +212,7 @@
 	basis/Itimer/set-gdb.o			\
 	basis/MLton/allocTooLarge-gdb.o		\
 	basis/MLton/bug-gdb.o			\
+	basis/MLton/Callback-gdb.o		\
 	basis/MLton/errno-gdb.o			\
 	basis/MLton/exit-gdb.o			\
 	basis/MLton/profile-gdb.o		\



1.23      +17 -0     mlton/runtime/mlton-basis.h

Index: mlton-basis.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/mlton-basis.h,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- mlton-basis.h	5 Jun 2003 22:57:14 -0000	1.22
+++ mlton-basis.h	19 Jun 2003 15:38:04 -0000	1.23
@@ -113,6 +113,23 @@
 void MLton_arrayTooLarge ();
 /* print a bug message and exit (2) */
 void MLton_bug (Pointer msg);
+
+Cstring MLton_Callback_callbackName();
+Cstring MLton_Callback_callbackType();
+/* SML functions */
+Bool MLton_Callback_fetchB(Int l);
+Char MLton_Callback_fetchC(Int l);
+Int MLton_Callback_fetchI(Int l);
+Double MLton_Callback_fetchR(Int l);
+Word MLton_Callback_fetchW(Int l);
+void MLton_Callback_retB(Bool b);
+void MLton_Callback_retC(Char c);
+void MLton_Callback_retI(Int i);
+void MLton_Callback_retR(Double r);
+void MLton_Callback_retW(Word w);
+/* C functions */
+int MLton_Callback_call(char *rep, char *name, ...);
+
 Int MLton_errno ();
 /* halt the machine */
 void MLton_exit (Int status);



1.1                  mlton/runtime/basis/MLton/Callback.c

Index: Callback.c
===================================================================
#include "mlton-basis.h"
#include "my-lib.h"
#include "stdarg.h"
#include "string.h"

static Bool argB[10];
static Char argC[10];
static Int argI[10];
static Double argR[10];
static Word argW[10];

static Bool resB;
static Char resC;
static Int resI;
static Double resR;
static Word resW;

Cstring callbackName;
Cstring callbackType;

Cstring MLton_Callback_callbackName() {
  return callbackName;
}

Cstring MLton_Callback_callbackType() {
  return callbackType;
}

/* SML functions */
Bool MLton_Callback_fetchB(Int l) {
  return argB[l];
}

Char MLton_Callback_fetchC(Int l) {
  return argC[l];
}

Int MLton_Callback_fetchI(Int l) {
  return argI[l];
}

Double MLton_Callback_fetchR(Int l) {
  return argR[l];
}

Word MLton_Callback_fetchW(Int l) {
  return argW[l];
}

void MLton_Callback_retB(Bool b) {
  resB = b;
}

void MLton_Callback_retC(Char c) {
  resC = c;
}

void MLton_Callback_retI(Int i) {
  resI = i;
}

void MLton_Callback_retR(Double r) {
  resR = r;
}

void MLton_Callback_retW(Word w) {
  resW = w;
}

/* C function */
void MLton_callFromC ();
int MLton_Callback_call(char *rep, char *name, ...) {
  int len, i;
  int indices[5] = {0,0,0,0,0};
  va_list ap;

  len = strlen(rep);
  for (i = 0; i < len; i++) {
    switch(rep[i]) {
    case 'B':
    case 'C':
    case 'I':
    case 'R':
    case 'U':
    case 'W':
      break;
    default: 
      return -1;
    }
  }

  va_start(ap, name);
  for (i = 0; i < len - 1; i++) {
    switch (rep[i]) {
    case 'B':
      argB[indices[0]++] = va_arg(ap, Bool);
      break;
    case 'C':
      argC[indices[1]++] = (Char)va_arg(ap, int);
      break;
    case 'I':
      argI[indices[2]++] = va_arg(ap, Int);
      break;
    case 'R':
      argR[indices[3]++] = va_arg(ap, Double);
      break;
    case 'U':
      break;
    case 'W':
      argW[indices[4]++] = va_arg(ap, Word);
      break;
    }
  }
  callbackName = (uint)name;
  callbackType = (uint)rep;
  MLton_callFromC();
  switch (rep[len-1]) {
  case 'B':
    *(va_arg(ap, Bool*)) = resB;
    break;
  case 'C':
    *(va_arg(ap, Char*)) = resC;
    break;
  case 'I':
    *(va_arg(ap, Int*)) = resI;
    break;
  case 'R':
    *(va_arg(ap, Double*)) = resR;
    break;
  case 'U':
    break;
  case 'W':
    *(va_arg(ap, Word*)) = resW;
    break;
  }
  va_end(ap);

  return 1;
}





-------------------------------------------------------
This SF.Net email is sponsored by: INetU
Attention Web Developers & Consultants: Become An INetU Hosting Partner.
Refer Dedicated Servers. We Manage Them. You Get 10% Monthly Commission!
INetU Dedicated Managed Hosting http://www.inetu.net/partner/index.php
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel