[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