[MLton-devel] cvs commit: _export bugfix and improvements
Stephen Weeks
sweeks@users.sourceforge.net
Sat, 05 Jul 2003 16:30:27 -0700
sweeks 03/07/05 16:30:26
Modified: basis-library/misc primitive.sml
basis-library/mlton ffi.sml thread.sig thread.sml
doc/examples/ffi Makefile export.sml ffi-export.c
include c-main.h x86-main.h
mlton/atoms type-ops.fun type-ops.sig
mlton/codegen/c-codegen c-codegen.fun
mlton/control control.sig control.sml
mlton/elaborate elaborate-core.fun
mlton/main compile.sml main.sml
runtime/basis Thread.c
Log:
Fixed the bug Ken Larsen triggered with mgtk. It was due to broken
use of atomic{Begin,End} in MLtonThread.sml. The reason the bug
didn't get caught in testing is that there is an optimization in the
basis library that turns atomic{Begin,End} into noops if signals
aren't handled by the program (because there can be no preemptive
thread switching). The only testing I had done with _export had been
with a single-threaded program and hence the critical sections hadn't
been tested at all. But mgtk uses MLton.Finalizable, which uses
signals, which triggered the bug.
First off, I decided to eliminate that optimization. Partly because
of this problem, and partly because there are various places in the
runtime and basis where you want to do asserts on canHandle, but these
won't be right if atomic{Begin,End} are turned into noops.
I moved the implementation of MLton.FFI.register into MLton.Thread,
since it was the only user of MLton.Thread.setCallFromCHandler. That
cleaned things up some. Modulo that change, the bugfix was to insert
an extra atomicBegin in the C code that switches to the handler, as
well as an extra atomicBegin in the SML code to counteract an
atomicEnd that happens the first time the handler is started.
Added option
-export-header {false|true} output header file for _export's
Now, the header file for _exports is not created automatically.
Instead, you must call mlton with -export-header true, which will
output the header to stdout and exit. This way, if you are creating a
library with _exports, you can create the header once and for all, and
users of your library don't have to know about it.
Added an example of mutually recursive C and SML functions to
doc/examples/ffi/export.sml.
Added support to allow values of type MLton.pointer to be passed
between C and SML.
Revision Changes Path
1.62 +4 -10 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.61
retrieving revision 1.62
diff -u -r1.61 -r1.62
--- primitive.sml 26 Jun 2003 03:28:19 -0000 1.61
+++ primitive.sml 5 Jul 2003 23:30:25 -0000 1.62
@@ -984,18 +984,12 @@
type preThread = preThread
type thread = thread
- fun atomicBegin () =
- if handlesSignals
- then _prim "Thread_atomicBegin": unit -> unit; ()
- else ()
+ val atomicBegin = _prim "Thread_atomicBegin": unit -> unit;
val canHandle = _prim "Thread_canHandle": unit -> int;
fun atomicEnd () =
- if handlesSignals
- then
- if Int.<= (canHandle (), 0)
- then raise Fail "Thread.atomicEnd with no atomicBegin"
- else _prim "Thread_atomicEnd": unit -> unit; ()
- else ()
+ if Int.<= (canHandle (), 0)
+ then raise Fail "Thread.atomicEnd with no atomicBegin"
+ else _prim "Thread_atomicEnd": unit -> unit; ()
val copy = _prim "Thread_copy": preThread -> thread;
(* copyCurrent's result is accesible via savedPre ().
* It is not possible to have the type of copyCurrent as
1.6 +1 -13 mlton/basis-library/mlton/ffi.sml
Index: ffi.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/ffi.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- ffi.sml 5 Jul 2003 21:14:33 -0000 1.5
+++ ffi.sml 5 Jul 2003 23:30:25 -0000 1.6
@@ -7,18 +7,6 @@
val atomicBegin = MLtonThread.atomicBegin
val atomicEnd = MLtonThread.atomicEnd
-
-val msg = Primitive.Stdio.print
-
-val register: int * (unit -> unit) -> unit =
- let
- val exports = Array.array (Prim.numExports, fn () =>
- raise Fail "undefined export\n")
- val _ =
- MLtonThread.setCallFromCHandler
- (fn () => Array.sub (exports, Prim.getOp ()) ())
- in
- fn (i, f) => Array.update (exports, i, f)
- end
+val register = MLtonThread.register
end
1.8 +1 -6 mlton/basis-library/mlton/thread.sig
Index: thread.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- thread.sig 19 Jun 2003 19:21:28 -0000 1.7
+++ thread.sig 5 Jul 2003 23:30:25 -0000 1.8
@@ -32,12 +32,7 @@
include MLTON_THREAD
val amInSignalHandler: unit -> bool
- (* setCallFromCHandler f
- * Installs f as the handler for calls from C into SML.
- * f should start in a critical section and
- * and should return in a critical section.
- *)
- val setCallFromCHandler: (unit -> unit) -> unit
+ val register: int * (unit -> unit) -> unit
val setHandler: (unit t -> unit t) -> unit
val switchToHandler: unit -> unit
end
1.21 +37 -29 mlton/basis-library/mlton/thread.sml
Index: thread.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sml,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- thread.sml 19 Jun 2003 19:21:28 -0000 1.20
+++ thread.sml 5 Jul 2003 23:30:25 -0000 1.21
@@ -52,6 +52,8 @@
; atomicEnd ()
; (x () handle e => MLtonExn.topLevelHandler e)
; die "Thread didn't exit properly.\n")))
+ fun newThread (f: unit -> unit) =
+ (func := SOME f; Prim.copy base)
val switching = ref false
in
fun ('a, 'b) switch'NoAtomicBegin (f: 'a t -> 'b t * (unit -> 'b)): 'a =
@@ -72,8 +74,7 @@
val primThread =
case !t' before (t' := Dead; switching := false) of
Dead => fail (Fail "switch to a Dead thread")
- | New g => (func := SOME (g o x)
- ; Prim.copy base)
+ | New g => newThread (g o x)
| Paused (f, t) => (f x; t)
val _ = Prim.switchTo primThread
(* Close the atomicBegin of the thread that switched to me. *)
@@ -145,36 +146,43 @@
Prim.setHandler p
end
-val msg = Primitive.Stdio.print
-
-val setCallFromCHandler =
+val register: int * (unit -> unit) -> unit =
let
- val r: (unit -> unit) ref =
- ref (fn () => raise Fail "no handler for C calls")
+ val exports = Array.array (Primitive.FFI.numExports, fn () =>
+ raise Fail "undefined export\n")
+ fun loop (): unit =
+ let
+ val t = Prim.saved ()
+ val _ =
+ Prim.switchTo
+ (toPrimitive
+ (new
+ (fn () =>
+ let
+ val _ =
+ (Array.sub (exports, Primitive.FFI.getOp ()) ())
+ handle e => (TextIO.output
+ (TextIO.stdErr,
+ "Call from C to SML raised exception.\n")
+ ; MLtonExn.topLevelHandler e)
+ val _ = Prim.setSaved t
+ val _ = Prim.returnToC ()
+ in
+ ()
+ end)))
+ in
+ loop ()
+ end
+ (* For some reason that I never figured out, the first time the handler
+ * is started, it does an extra atomicEnd (three instead of two). So, I
+ * inserted an extra atomicBegin before entering the loop.
+ *)
val _ =
- Prim.setCallFromCHandler
- (toPrimitive
- (new (let
- fun loop (): unit =
- let
- val t = Prim.saved ()
- val _ =
- Prim.switchTo
- (toPrimitive
- (new (fn () =>
- (let in
- (!r) ()
- ; Prim.setSaved t
- ; Prim.returnToC ()
- end))))
- in
- loop ()
- end
- in
- loop
- end)))
+ Prim.setCallFromCHandler (toPrimitive (new (fn () =>
+ (atomicBegin ()
+ ; loop ()))))
in
- fn f => r := f
+ fn (i, f) => Array.update (exports, i, f)
end
fun switchToHandler () =
1.6 +3 -1 mlton/doc/examples/ffi/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/Makefile,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- Makefile 24 Jun 2003 20:14:21 -0000 1.5
+++ Makefile 5 Jul 2003 23:30:25 -0000 1.6
@@ -4,7 +4,9 @@
all: import export
export: export.sml ffi-export.c
- $(mlton) export.sml ffi-export.c
+ $(mlton) -export-header true >export.h export.sml
+ gcc -c -I/usr/lib/mlton/self/include ffi-export.c
+ $(mlton) -debug true -native false export.sml ffi-export.o
import: import.sml ffi-import.o
$(mlton) import.sml ffi-import.o
1.4 +7 -10 mlton/doc/examples/ffi/export.sml
Index: export.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/export.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- export.sml 26 Jun 2003 19:12:27 -0000 1.3
+++ export.sml 5 Jul 2003 23:30:25 -0000 1.4
@@ -1,31 +1,28 @@
val e = _export "f": int * real -> char;
-
val _ = e (fn (i, r) =>
(print (concat ["i = ", Int.toString i,
" r = ", Real.toString r, "\n"])
; #"g"))
-
-
val g = _ffi "g": unit -> unit;
val _ = g ()
val _ = g ()
val e = _export "f2": Word8.word -> word array;
-
val _ = e (fn w => Array.tabulate (10, fn _ => Word8.toLargeWord w))
-
val g2 = _ffi "g2": unit -> word array;
-
val a = g2 ()
-
val _ = print (concat ["0wx", Word.toString (Array.sub (a, 0)), "\n"])
val e = _export "f3": unit -> unit;
-
val _ = e (fn () => print "hello\n");
-
val g3 = _ffi "g3": unit -> unit;
-
val _ = g3 ()
+(* This example demonstrates mutual recursion between C and SML. *)
+val e = _export "f4": int -> unit;
+val g4 = _ffi "g4": int -> unit;
+val _ = e (fn i => if i = 0 then () else g4 (i - 1))
+val _ = g4 13
+
val _ = print "success\n"
+
1.3 +5 -0 mlton/doc/examples/ffi/ffi-export.c
Index: ffi-export.c
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/ffi-export.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- ffi-export.c 24 Jun 2003 22:58:39 -0000 1.2
+++ ffi-export.c 5 Jul 2003 23:30:25 -0000 1.3
@@ -22,3 +22,8 @@
f3 ();
fprintf (stderr, "g3 done\n");
}
+
+void g4 (Int i) {
+ fprintf (stderr, "g4 (%d)\n", i);
+ f4 (i);
+}
1.6 +2 -2 mlton/include/c-main.h
Index: c-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-main.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- c-main.h 23 Jun 2003 04:58:54 -0000 1.5
+++ c-main.h 5 Jul 2003 23:30:25 -0000 1.6
@@ -16,8 +16,8 @@
fprintf (stderr, "MLton_callFromC() starting\n"); \
s = &gcState; \
s->savedThread = s->currentThread; \
- s->canHandle++; \
- /* Return to the C Handler thread. */ \
+ s->canHandle += 2; \
+ /* Switch to the C Handler thread. */ \
GC_switchToThread (s, s->callFromCHandler); \
nextFun = *(int*)(s->stackTop - WORD_SIZE); \
cont.nextChunk = nextChunks[nextFun]; \
1.6 +1 -1 mlton/include/x86-main.h
Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- x86-main.h 23 Jun 2003 04:58:54 -0000 1.5
+++ x86-main.h 5 Jul 2003 23:30:25 -0000 1.6
@@ -71,7 +71,7 @@
fprintf (stderr, "MLton_callFromC() starting\n"); \
s = &gcState; \
s->savedThread = s->currentThread; \
- s->canHandle++; \
+ s->canHandle += 2; \
/* Return to the C Handler thread. */ \
GC_switchToThread (s, s->callFromCHandler); \
jump = *(pointer*)(s->stackTop - WORD_SIZE); \
1.7 +1 -0 mlton/mlton/atoms/type-ops.fun
Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- type-ops.fun 23 Jun 2003 04:58:55 -0000 1.6
+++ type-ops.fun 5 Jul 2003 23:30:25 -0000 1.7
@@ -29,6 +29,7 @@
val exn = nullary Tycon.exn
val int = IntSize.memoize (fn s => nullary (Tycon.int s))
val intInf = nullary Tycon.intInf
+ val pointer = nullary Tycon.pointer
val preThread = nullary Tycon.preThread
val real = RealSize.memoize (fn s => nullary (Tycon.real s))
val thread = nullary Tycon.thread
1.7 +1 -0 mlton/mlton/atoms/type-ops.sig
Index: type-ops.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- type-ops.sig 23 Jun 2003 04:58:55 -0000 1.6
+++ type-ops.sig 5 Jul 2003 23:30:25 -0000 1.7
@@ -60,6 +60,7 @@
val isTuple: t -> bool
val list: t -> t
val nth: t * int -> t
+ val pointer: t
val preThread: t
val real: realSize -> t
val reff: t -> t
1.59 +2 -12 mlton/mlton/codegen/c-codegen/c-codegen.fun
Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -r1.58 -r1.59
--- c-codegen.fun 24 Jun 2003 20:14:22 -0000 1.58
+++ c-codegen.fun 5 Jul 2003 23:30:26 -0000 1.59
@@ -242,18 +242,8 @@
let
fun declareExports () =
if Ffi.numExports () > 0
- then
- let
- val _ = Ffi.declareExports {print = print}
- val {print, done} = outputH ()
- val _ = print "#include \"types.h\"\n"
- val _ = Ffi.declareHeaders {print = print}
- val _ = done ()
- in
- ()
- end
- else
- ()
+ then Ffi.declareExports {print = print}
+ else ()
fun declareLoadSaveGlobals () =
let
val _ =
1.76 +3 -1 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -r1.75 -r1.76
--- control.sig 18 Jun 2003 17:40:50 -0000 1.75
+++ control.sig 5 Jul 2003 23:30:26 -0000 1.76
@@ -50,8 +50,10 @@
(* whether optimization passes should eliminate useless overflow tests *)
val eliminateOverflow: bool ref
- val exnHistory: bool ref
+ val exportHeader: bool ref
+ val exnHistory: bool ref
+
(* *)
datatype gcCheck =
Limit
1.92 +5 -0 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.91
retrieving revision 1.92
diff -u -r1.91 -r1.92
--- control.sml 18 Jun 2003 17:40:50 -0000 1.91
+++ control.sml 5 Jul 2003 23:30:26 -0000 1.92
@@ -80,6 +80,11 @@
control {name = "eliminate overflow",
default = true,
toString = Bool.toString}
+
+val exportHeader =
+ control {name = "export header",
+ default = false,
+ toString = Bool.toString}
val exnHistory = control {name = "exn history",
default = false,
1.21 +2 -1 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- elaborate-core.fun 26 Jun 2003 19:17:30 -0000 1.20
+++ elaborate-core.fun 5 Jul 2003 23:30:26 -0000 1.21
@@ -336,7 +336,8 @@
val nullary =
[(Bool, Ctype.bool),
- (Char, Ctype.con (Tycon.char, Vector.new0 ()))]
+ (Char, Ctype.con (Tycon.char, Vector.new0 ())),
+ (Pointer, Ctype.pointer)]
@ List.map (IntSize.all, fn s => (Int s, Ctype.int s))
@ List.map (RealSize.all, fn s => (Real s, Ctype.real s))
@ List.map (WordSize.all, fn s => (Word s, Ctype.word s))
1.56 +14 -2 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- compile.sml 26 Jun 2003 19:17:30 -0000 1.55
+++ compile.sml 5 Jul 2003 23:30:26 -0000 1.56
@@ -347,9 +347,20 @@
(Elaborate.Env.layoutUsed basisEnv,
Out.standard)
in
- Process.succeed ()
+ Process.succeed ()
end
else parseAndElaborateFiles (input, basisEnv)
+ val _ =
+ if not (!Control.exportHeader)
+ then ()
+ else
+ let
+ val _ = Ffi.declareExports {print = fn _ => ()}
+ val _ = print "#include \"types.h\"\n"
+ val _ = Ffi.declareHeaders {print = print}
+ in
+ Process.succeed ()
+ end
val user = Decs.appends [prefix, input, suffix]
val _ = parseElabMsg ()
val basis = Decs.toList basis
@@ -501,7 +512,8 @@
outputH = outputH}
val _ = Control.message (Control.Detail, PropertyList.stats)
val _ = Control.message (Control.Detail, HashSet.stats)
- in ()
+ in
+ ()
end
end
1.140 +3 -0 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.139
retrieving revision 1.140
diff -u -r1.139 -r1.140
--- main.sml 24 Jun 2003 20:14:22 -0000 1.139
+++ main.sml 5 Jul 2003 23:30:26 -0000 1.140
@@ -167,6 +167,9 @@
(Expert, "expert", " {false|true}",
"enable expert status",
boolRef expert),
+ (Normal, "export-header", " {false|true}",
+ "output header file for _export's",
+ boolRef exportHeader),
(Expert, "gc-check", " {limit|first|every}", "force GCs",
SpaceString (fn s =>
gcCheck :=
1.11 +2 -0 mlton/runtime/basis/Thread.c
Index: Thread.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Thread.c,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- Thread.c 19 Apr 2003 17:12:16 -0000 1.10
+++ Thread.c 5 Jul 2003 23:30:26 -0000 1.11
@@ -31,6 +31,8 @@
}
void Thread_setSaved (Thread t) {
+ if (DEBUG_THREAD)
+ fprintf (stderr, "Thread_setSaved (0x%08x)\n", (uint)t);
gcState.savedThread = (GC_thread)t;
}
-------------------------------------------------------
This SF.Net email sponsored by: Free pre-built ASP.NET sites including
Data Reports, E-commerce, Portals, and Forums are available now.
Download today and enter to win an XBOX or Visual Studio .NET.
http://aspnet.click-url.com/go/psa00100006ave/direct;at.asp_061203_01/01
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel