[MLton-devel] cvs commit: calling SML from C
Stephen Weeks
MLton@mlton.org
Mon, 24 Mar 2003 20:31:25 -0800
sweeks 03/03/24 20:31:25
Modified: basis-library/libs build
basis-library/misc primitive.sml
basis-library/mlton mlton.sig mlton.sml thread.sig
thread.sml
include ccodegen.h
lib/mlton-stubs mlton.sig mlton.sml sources.cm thread.sig
mlton/atoms prim.fun prim.sig
mlton/backend c-function.fun c-function.sig limit-check.fun
ssa-to-rssa.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-generate-transfers.fun
x86-jump-info.fun x86-mlton.fun x86.fun
runtime gc.c gc.h
runtime/basis Thread.c
Added: basis-library/mlton ffi.sig ffi.sml
lib/mlton-stubs ffi.sig
Log:
This checkin includes a simple mechanism for calling SML from C.
Warning: it only works with -native false for now. The interface is
as follows. On the SML side, we export a single function that allows
one to set the "handler" that runs when a call to SML is made from C:
val MLton.FFI.handleCallFromC: (unit -> unit) -> unit
On the C side, we export a single function that allows us to call back
to SML:
void MLton_callFromC ();
This interface and implementation is only intended to handle the
situation where SML is the main program and calls C functions that may
need to call back to SML, which is the case for mGTK. It is easy
enough to use this primitive interface to implement the ability to
call multiple SML functions with wrappers around MLton_callFromC that
set a global integer and dispatch inside handleCallFromC that tests
the integer. It is also easy enough to pass arguments to the SML
functions, again by setting globals in the C wrapper and fetching them
(with _ffi) on the SML side. So, it is my hope that this interface
will be sufficient for the mGTK guys.
This interface is not intended to allow creation of SML libraries as
.o files. But it's hopefully a step in that direction.
The implementation is based on Matthew's suggestion of using threads
to handle callbacks and is very similar to how MLton handles signals.
There is a new field, gcState.callFromCHandler, that points to the
thread that is to be run when C calls MLton_callFromC (). There is
also one new primitive, Thread_returnToC, that the callFromCHandler
calls when it is done. Calling MLton_callFromC () switches to the
callFromCHandlerThread, and then runs the SML until it calls
Thread_returnToC. It then switches back to the thread that was
"interrupted" by the C call, and returns to C.
One major impact of allowing C to call back to SML is that it changes
the assumptions that the optimizer can make about C calls. Namely, it
used to be a safe assumption that anything declared by _ffi didn't
modify the frontier or the stackTop and didn't GC. Now, that is no
longer true, since any _ffi might call back to C, which could do any
of those things. There are two ways to solve this problem.
1. If the program handles C calls, then assume that all _ffi's may
modify the frontier or the stackTop and may GC.
2. Introduce an annotation on _ffi declarations that allows the
programmer to indicate the functions that may callback.
3. Introduce an annotation on _ffi declarations that allows the
programmer to indicate the functions that don't callback.
For now I've chosen (1), but only because it was easier to implement.
In looking at this, I see that we go to a lot of trouble in the
backend and codegen to keep track of all of these properties of C
functions (modifiesFrontier, mayGC, ...) in the backend so that the
codegens can optimize C calls. It might make our lives a lot easier,
and the compiler more obviously correct, to simply make worst case
assumptions for some of these. I don't know much that will hurt
performance. It's probably worth running some experiments to check.
Warning: this checkin only supports calling SML from C with the C
codegen. To get it to work with the native codegen, two things must
be done:
1. Add an implementation of MLton_callFromC to x86codegen.h. It
shouldn't be too hard to pattern match off of MLton_callFromC in
ccodegen.h and main in x86codegen.h.
2. Implement C calls to Thread_returnToC in the x86 codegen. Again,
the semantics are in the C codegen.
Matthew, can you look into those two things?
Revision Changes Path
1.10 +2 -0 mlton/basis-library/libs/build
Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- build 8 Feb 2003 23:29:37 -0000 1.9
+++ build 25 Mar 2003 04:31:22 -0000 1.10
@@ -195,6 +195,8 @@
mlton/bin-io.sig
mlton/itimer.sig
mlton/itimer.sml
+mlton/ffi.sig
+mlton/ffi.sml
mlton/gc.sig
mlton/gc.sml
mlton/int-inf.sig
1.46 +4 -0 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- primitive.sml 3 Jan 2003 06:14:13 -0000 1.45
+++ primitive.sml 25 Mar 2003 04:31:22 -0000 1.46
@@ -754,9 +754,13 @@
val copyCurrent = _prim "Thread_copyCurrent": unit -> unit;
val current = _ffi "Thread_current": unit -> thread;
val finishHandler = _ffi "Thread_finishHandler": unit -> unit;
+ val returnToC = _prim "Thread_returnToC": unit -> unit;
val saved = _ffi "Thread_saved": unit -> thread;
val savedPre = _ffi "Thread_saved": unit -> preThread;
+ val setCallFromCHandler =
+ _ffi "Thread_setCallFromCHandler": thread -> unit;
val setHandler = _ffi "Thread_setHandler": thread -> unit;
+ val setSaved = _ffi "Thread_setSaved": thread -> unit;
val startHandler = _ffi "Thread_startHandler": unit -> unit;
val switchTo = _prim "Thread_switchTo": thread -> unit;
end
1.18 +1 -0 mlton/basis-library/mlton/mlton.sig
Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sig,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- mlton.sig 3 Jan 2003 06:14:13 -0000 1.17
+++ mlton.sig 25 Mar 2003 04:31:22 -0000 1.18
@@ -28,6 +28,7 @@
structure BinIO: MLTON_BIN_IO
structure Cont: MLTON_CONT
structure Exn: MLTON_EXN
+ structure FFI: MLTON_FFI
structure GC: MLTON_GC
structure IntInf: MLTON_INT_INF
structure Itimer: MLTON_ITIMER
1.18 +1 -0 mlton/basis-library/mlton/mlton.sml
Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sml,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- mlton.sml 3 Jan 2003 06:14:13 -0000 1.17
+++ mlton.sml 25 Mar 2003 04:31:23 -0000 1.18
@@ -52,6 +52,7 @@
end
structure Cont = MLtonCont
structure Exn = MLtonExn
+structure FFI = MLtonFFI
structure GC = MLtonGC
structure IntInf = IntInf
structure Itimer = MLtonItimer
1.5 +1 -0 mlton/basis-library/mlton/thread.sig
Index: thread.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- thread.sig 22 Jul 2002 03:37:31 -0000 1.4
+++ thread.sig 25 Mar 2003 04:31:23 -0000 1.5
@@ -32,6 +32,7 @@
include MLTON_THREAD
val amInSignalHandler: unit -> bool
+ val setCallFromCHandler: (unit -> unit) -> unit
val setHandler: (unit t -> unit t) -> unit
val switchToHandler: unit -> unit
end
1.15 +26 -1 mlton/basis-library/mlton/thread.sml
Index: thread.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sml,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- thread.sml 29 Dec 2002 01:22:58 -0000 1.14
+++ thread.sml 25 Mar 2003 04:31:23 -0000 1.15
@@ -139,10 +139,35 @@
loop ()
end
val p =
- toPrimitive (new (fn () => loop () handle e => MLtonExn.topLevelHandler e))
+ toPrimitive
+ (new (fn () => loop () handle e => MLtonExn.topLevelHandler e))
val _ = signalHandler := SOME p
in
Prim.setHandler p
+ end
+
+val setCallFromCHandler =
+ let
+ val r: (unit -> unit) ref =
+ ref (fn () => raise Fail "no handler for C calls")
+ val _ =
+ Prim.setCallFromCHandler
+ (toPrimitive
+ (new (let
+ fun loop (): unit =
+ let
+ val t = Prim.saved ()
+ in
+ !r () handle e => MLtonExn.topLevelHandler e
+ ; Prim.setSaved t
+ ; Prim.returnToC ()
+ ; loop ()
+ end
+ in
+ loop
+ end)))
+ in
+ fn f => r := f
end
fun switchToHandler () =
1.1 mlton/basis-library/mlton/ffi.sig
Index: ffi.sig
===================================================================
signature MLTON_FFI =
sig
val handleCallFromC: (unit -> unit) -> unit
end
1.1 mlton/basis-library/mlton/ffi.sml
Index: ffi.sml
===================================================================
structure MLtonFFI =
struct
val handleCallFromC = MLtonThread.setCallFromCHandler
end
1.51 +34 -1 mlton/include/ccodegen.h
Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- ccodegen.h 28 Jan 2003 06:56:14 -0000 1.50
+++ ccodegen.h 25 Mar 2003 04:31:23 -0000 1.51
@@ -81,7 +81,7 @@
leaveChunk: \
FlushFrontier(); \
FlushStackTop(); \
- return(cont); \
+ return cont; \
} /* end switch (l_nextFun) */ \
} /* end while (1) */ \
} /* end chunk */
@@ -90,7 +90,40 @@
/* main */
/* ------------------------------------------------- */
+static bool returnToC;
+
+#define Thread_returnToC() \
+ do { \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "%d Thread_returnToC()\n", \
+ __LINE__); \
+ returnToC = TRUE; \
+ return cont; \
+ } while (0)
+
+
#define Main(cs, mg, mfs, mlw, mmc, ps, mc, ml) \
+void MLton_callFromC () { \
+ struct cont cont; \
+ GC_state s; \
+ \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "MLton_callFromC() starting\n"); \
+ s = &gcState; \
+ s->savedThread = s->currentThread; \
+ /* Return to the C Handler thread. */ \
+ GC_switchToThread (s, s->callFromCHandler); \
+ nextFun = *(int*)(s->stackTop - WORD_SIZE); \
+ cont.nextChunk = nextChunks[nextFun]; \
+ returnToC = FALSE; \
+ do { \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ } while (not returnToC); \
+ GC_switchToThread (s, s->savedThread); \
+ s->savedThread = BOGUS_THREAD; \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "MLton_callFromC done\n"); \
+} \
int main (int argc, char **argv) { \
struct cont cont; \
gcState.native = FALSE; \
1.8 +1 -0 mlton/lib/mlton-stubs/mlton.sig
Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- mlton.sig 31 Oct 2002 19:30:13 -0000 1.7
+++ mlton.sig 25 Mar 2003 04:31:23 -0000 1.8
@@ -28,6 +28,7 @@
structure BinIO: MLTON_BIN_IO
structure Cont: MLTON_CONT
structure Exn: MLTON_EXN
+ structure FFI: MLTON_FFI
structure GC: MLTON_GC
structure IntInf: MLTON_INT_INF
structure Itimer: MLTON_ITIMER
1.13 +5 -0 mlton/lib/mlton-stubs/mlton.sml
Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sml,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- mlton.sml 11 Feb 2003 22:13:28 -0000 1.12
+++ mlton.sml 25 Mar 2003 04:31:23 -0000 1.13
@@ -92,6 +92,11 @@
val topLevelHandler = fn _ => raise Fail "Exn.topLevelHandler"
end
+ structure FFI =
+ struct
+ val handleCallFromC = fn _ => raise Fail "FFI.handleCallFromC"
+ end
+
structure GC =
struct
fun collect _ = ()
1.6 +1 -0 mlton/lib/mlton-stubs/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/sources.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- sources.cm 30 Jan 2003 04:43:15 -0000 1.5
+++ sources.cm 25 Mar 2003 04:31:23 -0000 1.6
@@ -65,6 +65,7 @@
bin-io.sml
cont.sig
exn.sig
+ffi.sig
gc.sig
int-inf.sig
int-inf.sml
1.4 +1 -0 mlton/lib/mlton-stubs/thread.sig
Index: thread.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/thread.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- thread.sig 6 Aug 2002 03:19:19 -0000 1.3
+++ thread.sig 25 Mar 2003 04:31:23 -0000 1.4
@@ -32,6 +32,7 @@
include MLTON_THREAD
val amInSignalHandler: unit -> bool
+ val setCallFromCHandler: (unit -> unit) -> unit
val setHandler: (unit t -> unit t) -> unit
val switchToHandler: unit -> unit
end
1.1 mlton/lib/mlton-stubs/ffi.sig
Index: ffi.sig
===================================================================
signature MLTON_FFI =
sig
val handleCallFromC: (unit -> unit) -> unit
end
1.45 +2 -0 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- prim.fun 28 Jan 2003 05:22:27 -0000 1.44
+++ prim.fun 25 Mar 2003 04:31:23 -0000 1.45
@@ -152,6 +152,7 @@
| Thread_canHandle
| Thread_copy
| Thread_copyCurrent
+ | Thread_returnToC
| Thread_switchTo
| Vector_fromArray
| Vector_length
@@ -372,6 +373,7 @@
(Thread_canHandle, DependsOnState, "Thread_canHandle"),
(Thread_copy, Moveable, "Thread_copy"),
(Thread_copyCurrent, SideEffect, "Thread_copyCurrent"),
+ (Thread_returnToC, SideEffect, "Thread_returnToC"),
(Thread_switchTo, SideEffect, "Thread_switchTo"),
(Vector_fromArray, DependsOnState, "Vector_fromArray"),
(Vector_length, Functional, "Vector_length"),
1.35 +1 -0 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- prim.sig 7 Dec 2002 02:21:51 -0000 1.34
+++ prim.sig 25 Mar 2003 04:31:23 -0000 1.35
@@ -157,6 +157,7 @@
| Thread_canHandle (* implemented in backend *)
| Thread_copy
| Thread_copyCurrent
+ | Thread_returnToC
(* switchTo has to be a _prim because we have to know that it
* enters the runtime -- because everything must be saved
* on the stack.
1.11 +14 -0 mlton/mlton/backend/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- c-function.fun 23 Jan 2003 03:34:36 -0000 1.10
+++ c-function.fun 25 Mar 2003 04:31:24 -0000 1.11
@@ -17,6 +17,10 @@
modifiesStackTop: bool,
name: string,
returnTy: Type.t option}
+
+val make = T
+
+fun dest (T r) = r
fun layout (T {bytesNeeded, ensuresBytesFree, mayGC, maySwitchThreads,
modifiesFrontier, modifiesStackTop, name, returnTy}) =
@@ -109,4 +113,14 @@
val size = vanilla {name = "MLton_size",
returnTy = SOME Type.int}
+val returnToC =
+ T {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ mayGC = true,
+ maySwitchThreads = true,
+ name = "Thread_returnToC",
+ returnTy = NONE}
+
end
1.8 +31 -16 mlton/mlton/backend/c-function.sig
Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- c-function.sig 23 Jan 2003 03:34:36 -0000 1.7
+++ c-function.sig 25 Mar 2003 04:31:24 -0000 1.8
@@ -17,29 +17,38 @@
sig
include C_FUNCTION_STRUCTS
- datatype t = T of {(* bytesNeeded = SOME i means that the i'th
- * argument to the function is a word that
- * specifies the number of bytes that must be
- * free in order for the C function to succeed.
- * Limit check insertion is responsible for
- * making sure that the bytesNeeded is available.
- *)
- bytesNeeded: int option,
- ensuresBytesFree: bool,
- modifiesFrontier: bool,
- modifiesStackTop: bool,
- mayGC: bool,
- maySwitchThreads: bool,
- name: string,
- returnTy: Type.t option}
-
+ type t
+
val bug: t
val bytesNeeded: t -> int option
+ val dest: t -> {bytesNeeded: int option,
+ ensuresBytesFree: bool,
+ modifiesFrontier: bool,
+ modifiesStackTop: bool,
+ mayGC: bool,
+ maySwitchThreads: bool,
+ name: string,
+ returnTy: Type.t option}
val ensuresBytesFree: t -> bool
val equals: t * t -> bool
val gc: {maySwitchThreads: bool} -> t
val isOk: t -> bool
val layout: t -> Layout.t
+ val make: {(* bytesNeeded = SOME i means that the i'th
+ * argument to the function is a word that
+ * specifies the number of bytes that must be
+ * free in order for the C function to succeed.
+ * Limit check insertion is responsible for
+ * making sure that the bytesNeeded is available.
+ *)
+ bytesNeeded: int option,
+ ensuresBytesFree: bool,
+ modifiesFrontier: bool,
+ modifiesStackTop: bool,
+ mayGC: bool,
+ maySwitchThreads: bool,
+ name: string,
+ returnTy: Type.t option} -> t
val mayGC: t -> bool
val maySwitchThreads: t -> bool
val modifiesFrontier: t -> bool
@@ -48,6 +57,12 @@
val profileEnter: t
val profileInc: t
val profileLeave: t
+ (* returnToC is not really a C function. Calls to it must be handled
+ * specially by each codegen to ensure that the C stack is handled
+ * correctly. However, for the purposes of the backend it looks like a
+ * call to C.
+ *)
+ val returnToC: t
val returnTy: t -> Type.t option
val size: t
val vanilla: {name: string, returnTy: Type.t option} -> t
1.37 +28 -25 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- limit-check.fun 12 Feb 2003 05:11:24 -0000 1.36
+++ limit-check.fun 25 Mar 2003 04:31:24 -0000 1.37
@@ -85,10 +85,13 @@
fun caseBytes (t: t, {big: Operand.t -> 'a,
small: word -> 'a}): 'a =
case t of
- CCall {args, func = CFunction.T {bytesNeeded = SOME i, ...}, ...} =>
- Operand.caseBytes (Vector.sub (args, i),
- {big = big,
- small = small})
+ CCall {args, func, ...} =>
+ (case CFunction.bytesNeeded func of
+ NONE => small 0w0
+ | SOME i =>
+ Operand.caseBytes (Vector.sub (args, i),
+ {big = big,
+ small = small}))
| _ => small 0w0
end
@@ -126,14 +129,14 @@
val l = Label.newNoname ()
val _ = r := SOME l
val cfunc =
- CFunction.T {bytesNeeded = NONE,
- ensuresBytesFree = false,
- mayGC = false,
- maySwitchThreads = false,
- modifiesFrontier = false,
- modifiesStackTop = false,
- name = "MLton_allocTooLarge",
- returnTy = NONE}
+ CFunction.make {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = false,
+ modifiesStackTop = false,
+ name = "MLton_allocTooLarge",
+ returnTy = NONE}
val _ =
newBlocks :=
Block.T {args = Vector.new0 (),
@@ -155,10 +158,8 @@
let
val transfer =
case transfer of
- Transfer.CCall {args,
- func as CFunction.T {ensuresBytesFree, ...},
- return} =>
- (if ensuresBytesFree
+ Transfer.CCall {args, func, return} =>
+ (if CFunction.ensuresBytesFree func
then
Transfer.CCall
{args = (Vector.map
@@ -487,18 +488,20 @@
val b =
case kind of
Cont _ => true
- | CReturn {func = CFunction.T {ensuresBytesFree, mayGC, ...}} =>
- mayGC andalso not ensuresBytesFree
+ | CReturn {func, ...} =>
+ CFunction.mayGC func
+ andalso not (CFunction.ensuresBytesFree func)
| Handler => true
| Jump =>
(case transfer of
- Transfer.CCall
- {args,
- func = CFunction.T {bytesNeeded = SOME i, ...},
- ...} => (case Vector.sub (args, i) of
- Operand.Const c => false
- | _ => true)
- | _ => false)
+ Transfer.CCall {args, func, ...} =>
+ (case CFunction.bytesNeeded func of
+ NONE => true
+ | SOME i =>
+ (case Vector.sub (args, i) of
+ Operand.Const c => false
+ | _ => true))
+ | _ => false)
in
b orelse isBigAlloc ()
end)
1.37 +65 -51 mlton/mlton/backend/ssa-to-rssa.fun
Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- ssa-to-rssa.fun 2 Feb 2003 03:17:08 -0000 1.36
+++ ssa-to-rssa.fun 25 Mar 2003 04:31:24 -0000 1.37
@@ -42,14 +42,14 @@
local
fun make (name, i) =
- T {bytesNeeded = SOME i,
- ensuresBytesFree = false,
- mayGC = false,
- maySwitchThreads = false,
- modifiesFrontier = true,
- modifiesStackTop = false,
- name = name,
- returnTy = SOME Type.pointer}
+ CFunction.make {bytesNeeded = SOME i,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = false,
+ name = name,
+ returnTy = SOME Type.pointer}
in
val intInfAdd = make ("IntInf_do_add", 2)
val intInfAndb = make ("IntInf_do_andb", 2)
@@ -76,27 +76,27 @@
end
val copyCurrentThread =
- T {bytesNeeded = NONE,
- ensuresBytesFree = false,
- mayGC = true,
- maySwitchThreads = false,
- modifiesFrontier = true,
- modifiesStackTop = true,
- name = "GC_copyCurrentThread",
- returnTy = NONE}
+ make {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_copyCurrentThread",
+ returnTy = NONE}
val copyThread =
- T {bytesNeeded = NONE,
- ensuresBytesFree = false,
- mayGC = true,
- maySwitchThreads = false,
- modifiesFrontier = true,
- modifiesStackTop = true,
- name = "GC_copyThread",
- returnTy = SOME Type.pointer}
+ make {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_copyThread",
+ returnTy = SOME Type.pointer}
val exit =
- T {bytesNeeded = NONE,
+ make {bytesNeeded = NONE,
ensuresBytesFree = false,
mayGC = false,
maySwitchThreads = false,
@@ -106,32 +106,32 @@
returnTy = NONE}
val gcArrayAllocate =
- T {bytesNeeded = NONE,
- ensuresBytesFree = true,
- mayGC = true,
- maySwitchThreads = false,
- modifiesFrontier = true,
- modifiesStackTop = true,
- name = "GC_arrayAllocate",
- returnTy = SOME Type.pointer}
-
- local
- fun make name =
- T {bytesNeeded = NONE,
- ensuresBytesFree = false,
+ make {bytesNeeded = NONE,
+ ensuresBytesFree = true,
mayGC = true,
maySwitchThreads = false,
modifiesFrontier = true,
modifiesStackTop = true,
- name = name,
- returnTy = NONE}
+ name = "GC_arrayAllocate",
+ returnTy = SOME Type.pointer}
+
+ local
+ fun make name =
+ CFunction.make {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = name,
+ returnTy = NONE}
in
val pack = make "GC_pack"
val unpack = make "GC_unpack"
end
val threadSwitchTo =
- T {bytesNeeded = NONE,
+ make {bytesNeeded = NONE,
ensuresBytesFree = true,
mayGC = true,
maySwitchThreads = true,
@@ -141,14 +141,14 @@
returnTy = NONE}
val worldSave =
- T {bytesNeeded = NONE,
- ensuresBytesFree = false,
- mayGC = true,
- maySwitchThreads = false,
- modifiesFrontier = true,
- modifiesStackTop = true,
- name = "GC_saveWorld",
- returnTy = NONE}
+ make {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_saveWorld",
+ returnTy = NONE}
end
datatype z = datatype Operand.t
@@ -168,6 +168,11 @@
fun convert (program as S.Program.T {functions, globals, main, ...})
: Rssa.Program.t =
let
+ val callsFromC =
+ S.Program.hasPrim (program, fn p =>
+ case Prim.name p of
+ Prim.Name.Thread_returnToC => true
+ | _ => false)
val {conRep, objectTypes, refRep, toRtype, tupleRep, tyconRep} =
Representation.compute program
val conRep =
@@ -988,8 +993,14 @@
then normal ()
else
simpleCCall
- (CFunction.vanilla
- {name = name,
+ (CFunction.make
+ {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ modifiesFrontier = callsFromC,
+ modifiesStackTop = callsFromC,
+ mayGC = callsFromC,
+ maySwitchThreads = false,
+ name = name,
returnTy =
Option.map
(var, fn x =>
@@ -1170,6 +1181,9 @@
[Vector.new1 Operand.GCState,
vos args]),
func = CFunction.copyThread}
+ | Thread_returnToC =>
+ ccall {args = vos args,
+ func = CFunction.returnToC}
| Thread_switchTo =>
ccall {args = (Vector.new2
(varOp (a 0),
1.47 +10 -13 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.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- c-codegen.fun 25 Feb 2003 20:44:23 -0000 1.46
+++ c-codegen.fun 25 Mar 2003 04:31:24 -0000 1.47
@@ -49,7 +49,7 @@
fun isEntry (k: t): bool =
case k of
Cont _ => true
- | CReturn {func = CFunction.T {mayGC, ...}, ...} => mayGC
+ | CReturn {func, ...} => CFunction.mayGC func
| Func => true
| Handler _ => true
| _ => false
@@ -518,9 +518,8 @@
case transfer of
Arith {overflow, success, ...} =>
(jump overflow; jump success)
- | CCall {func = CFunction.T {maySwitchThreads, ...},
- return, ...} =>
- if maySwitchThreads
+ | CCall {func, return, ...} =>
+ if CFunction.maySwitchThreads func
then ()
else Option.app (return, jump)
| Call {label, ...} => jump label
@@ -716,16 +715,14 @@
; gotoLabel success
; maybePrintLabel overflow
end
- | CCall {args,
- frameInfo,
- func = CFunction.T {maySwitchThreads,
- modifiesFrontier,
- modifiesStackTop,
- name,
- returnTy,
- ...},
- return} =>
+ | CCall {args, frameInfo, func, return} =>
let
+ val {maySwitchThreads,
+ modifiesFrontier,
+ modifiesStackTop,
+ name,
+ returnTy,
+ ...} = CFunction.dest func
val (args, afterCall) =
case frameInfo of
NONE =>
1.39 +7 -13 mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun
Index: x86-generate-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- x86-generate-transfers.fun 23 Jan 2003 03:34:37 -0000 1.38
+++ x86-generate-transfers.fun 25 Mar 2003 04:31:24 -0000 1.39
@@ -506,11 +506,7 @@
= case entry
of Jump {label}
=> near label
- | CReturn {dst,
- frameInfo,
- func = CFunction.T {maySwitchThreads,
- ...},
- label}
+ | CReturn {dst, frameInfo, func, label}
=> let
fun getReturn ()
= case dst
@@ -569,7 +565,7 @@
Assembly.label label],
AppendList.fromList
(ProfileLabel.toAssemblyOpt profileLabel),
- if maySwitchThreads
+ if CFunction.maySwitchThreads func
then (* entry from far assumptions *)
farEntry finish
else (* near entry & live transfer assumptions *)
@@ -1077,14 +1073,12 @@
{target = x86MLton.gcState_stackTopMinusWordDerefOperand (),
absolute = true})))
end
- | CCall {args, dstsize,
- frameInfo,
- func = CFunction.T {maySwitchThreads,
- modifiesFrontier,
- modifiesStackTop,
- name, ...},
- return, target}
+ | CCall {args, dstsize, frameInfo, func, return, target}
=> let
+ val {maySwitchThreads,
+ modifiesFrontier,
+ modifiesStackTop,
+ name, ...} = CFunction.dest func
val stackTopMinusWordDeref
= x86MLton.gcState_stackTopMinusWordDerefOperand ()
val {dead, ...}
1.11 +2 -5 mlton/mlton/codegen/x86-codegen/x86-jump-info.fun
Index: x86-jump-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-jump-info.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-jump-info.fun 11 Jul 2002 02:16:49 -0000 1.10
+++ x86-jump-info.fun 25 Mar 2003 04:31:25 -0000 1.11
@@ -65,11 +65,8 @@
| Entry.Func {label, ...} => forceNear (jumpInfo, label)
| Entry.Cont {label, ...} => forceNear (jumpInfo, label)
| Entry.Handler {label, ...} => forceNear (jumpInfo, label)
- | Entry.CReturn {label,
- func = Runtime.CFunction.T {maySwitchThreads,
- ...},
- ...}
- => if maySwitchThreads
+ | Entry.CReturn {label, func, ...}
+ => if Runtime.CFunction.maySwitchThreads func
then forceNear (jumpInfo, label)
else ();
List.foreach
1.42 +2 -1 mlton/mlton/codegen/x86-codegen/x86-mlton.fun
Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- x86-mlton.fun 20 Jan 2003 16:28:33 -0000 1.41
+++ x86-mlton.fun 25 Mar 2003 04:31:25 -0000 1.42
@@ -1314,10 +1314,11 @@
fun ccall {args: (x86.Operand.t * x86.Size.t) vector,
frameInfo,
- func as CFunction.T {name, returnTy, ...},
+ func,
return: x86.Label.t option,
transInfo: transInfo}
= let
+ val {name, returnTy, ...} = CFunction.dest func
val dstsize = Option.map (returnTy, toX86Size)
val comment_begin
= if !Control.Native.commented > 0
1.36 +3 -3 mlton/mlton/codegen/x86-codegen/x86.fun
Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- x86.fun 20 Jan 2003 16:28:38 -0000 1.35
+++ x86.fun 25 Mar 2003 04:31:25 -0000 1.36
@@ -3707,8 +3707,8 @@
val creturn = CReturn
val isNear = fn Jump _ => true
- | CReturn {func = CFunction.T {maySwitchThreads, ... }, ...}
- => not maySwitchThreads
+ | CReturn {func, ...}
+ => not (CFunction.maySwitchThreads func)
| _ => false
end
@@ -4017,7 +4017,7 @@
| NonTail {return,handler,...} => return::(case handler
of NONE => nil
| SOME handler => [handler])
- | CCall {return, func = CFunction.T {maySwitchThreads, ...}, ...}
+ | CCall {return, ...}
=> (case return of
NONE => []
| SOME l => [l])
1.126 +4 -2 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.125
retrieving revision 1.126
diff -u -r1.125 -r1.126
--- gc.c 11 Feb 2003 17:21:54 -0000 1.125
+++ gc.c 25 Mar 2003 04:31:25 -0000 1.126
@@ -60,7 +60,6 @@
enum {
BOGUS_EXN_STACK = 0xFFFFFFFF,
- BOGUS_POINTER = 0x1,
COPY_CHUNK_SIZE = 0x800000,
CURRENT_SOURCE_UNDEFINED = 0xFFFFFFFF,
DEBUG = FALSE,
@@ -86,7 +85,6 @@
UNMARK_MODE,
} MarkMode;
-#define BOGUS_THREAD (GC_thread)BOGUS_POINTER
#define STACK_HEADER GC_objectHeader (STACK_TYPE_INDEX)
#define STRING_HEADER GC_objectHeader (STRING_TYPE_INDEX)
#define THREAD_HEADER GC_objectHeader (THREAD_TYPE_INDEX)
@@ -771,6 +769,7 @@
}
if (DEBUG_DETAILED)
fprintf (stderr, "foreachGlobal threads\n");
+ maybeCall (f, s, (pointer*)&s->callFromCHandler);
maybeCall (f, s, (pointer*)&s->currentThread);
maybeCall (f, s, (pointer*)&s->savedThread);
maybeCall (f, s, (pointer*)&s->signalHandler);
@@ -3635,6 +3634,7 @@
die ("Invalid world: wrong magic number.");
oldGen = (pointer) sfreadUint (file);
s->oldGenSize = sfreadUint (file);
+ s->callFromCHandler = (GC_thread) sfreadUint (file);
s->currentThread = (GC_thread) sfreadUint (file);
s->signalHandler = (GC_thread) sfreadUint (file);
heapCreate (s, &s->heap, heapDesiredSize (s, s->oldGenSize, 0),
@@ -3666,6 +3666,7 @@
s->bytesCopied = 0;
s->bytesCopiedMinor = 0;
s->bytesMarkCompacted = 0;
+ s->callFromCHandler = BOGUS_THREAD;
s->canHandle = 0;
s->cardSize = 0x1 << s->cardSizeLog2;
s->copyRatio = 4.0;
@@ -3993,6 +3994,7 @@
swriteUint (fd, s->magic);
swriteUint (fd, (uint)s->heap.start);
swriteUint (fd, (uint)s->oldGenSize);
+ swriteUint (fd, (uint)s->callFromCHandler);
swriteUint (fd, (uint)s->currentThread);
swriteUint (fd, (uint)s->signalHandler);
swrite (fd, s->heap.start, s->oldGenSize);
1.57 +4 -0 mlton/runtime/gc.h
Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- gc.h 23 Jan 2003 03:34:38 -0000 1.56
+++ gc.h 25 Mar 2003 04:31:25 -0000 1.57
@@ -63,6 +63,7 @@
/* Sizes are (almost) always measured in bytes. */
enum {
+ BOGUS_POINTER = 0x1,
WORD_SIZE = 4,
COUNTER_MASK = 0x7FF00000,
COUNTER_SHIFT = 20,
@@ -84,6 +85,8 @@
WORD_VECTOR_TYPE_INDEX = 3,
};
+#define BOGUS_THREAD (GC_thread)BOGUS_POINTER
+
#define TWOPOWER(n) (1 << (n))
/* ------------------------------------------------- */
@@ -299,6 +302,7 @@
ullong bytesCopiedMinor;
int bytesLive; /* Number of bytes live at most recent major GC. */
ullong bytesMarkCompacted;
+ GC_thread callFromCHandler; /* For C calls. */
bool canMinor; /* TRUE iff there is space for a minor gc. */
pointer cardMap;
pointer cardMapForMutator;
1.8 +8 -0 mlton/runtime/basis/Thread.c
Index: Thread.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Thread.c,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- Thread.c 22 Jul 2002 03:37:31 -0000 1.7
+++ Thread.c 25 Mar 2003 04:31:25 -0000 1.8
@@ -20,6 +20,14 @@
return t;
}
+void Thread_setCallFromCHandler (Thread t) {
+ gcState.callFromCHandler = (GC_thread)t;
+}
+
+Thread Thread_setSaved (Thread t) {
+ gcState.savedThread = (GC_thread)t;
+}
+
void Thread_setHandler (Thread t) {
gcState.signalHandler = (GC_thread)t;
}
-------------------------------------------------------
This SF.net email is sponsored by:
The Definitive IT and Networking Event. Be There!
NetWorld+Interop Las Vegas 2003 -- Register today!
http://ads.sourceforge.net/cgi-bin/redirect.pl?keyn0001en
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel