[MLton] cvs commit: critical sections during thread switch
Matthew Fluet
fluet@mlton.org
Thu, 1 Apr 2004 18:49:53 -0800
fluet 04/04/01 18:49:52
Modified: basis-library/mlton cont.sml thread.sig thread.sml
include c-main.h x86-main.h
mlton/backend ssa-to-rssa.fun
runtime gc.c
runtime/basis Thread.c
Log:
MAIL critical sections during thread switch
Added an implicit canHandle-- to GC_switchToThread. This meant
adjusting a lot of the atomicBegin/End calls in thread.sml and
cont.sml. I've annotated the code with the expected atomic state;
(technically, the least value of the atomic state; everything should
be fine if the calls are nested within an outer critical section; upon
returning to user code, the atomic state should be the same as upon
entry).
Rather than having two separate switchTo calls, I just put an extra
atomicBegin when switching to a New thread; this prevents switching
threads at the implicit canHandle-- in GC_switchToThread; once the new
thread is copied and ready to run, we atomicEnd.
While I was at it, I modified the ssa-to-rssa translation to force a
collection when atomicEnd drops the atomic state to 0 and a signal is
pending.
Revision Changes Path
1.11 +1 -2 mlton/basis-library/mlton/cont.sml
Index: cont.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/cont.sml,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- cont.sml 29 Dec 2002 01:22:58 -0000 1.10
+++ cont.sml 2 Apr 2004 02:49:51 -0000 1.11
@@ -1,7 +1,6 @@
structure MLtonCont:> MLTON_CONT =
struct
-structure Thread' = MLtonThread
structure Thread = Primitive.Thread
(* This mess with dummy is so that if callcc is ever used anywhere in the
@@ -17,7 +16,7 @@
fun callcc (f: 'a t -> 'a): 'a =
(dummy ()
- ; if Thread'.amInSignalHandler ()
+ ; if MLtonThread.amInSignalHandler ()
then die "callcc can not be used in a signal handler\n"
else
let
1.10 +38 -2 mlton/basis-library/mlton/thread.sig
Index: thread.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- thread.sig 30 Mar 2004 01:44:13 -0000 1.9
+++ thread.sig 2 Apr 2004 02:49:51 -0000 1.10
@@ -6,11 +6,17 @@
*)
signature MLTON_THREAD =
sig
- type 'a t
-
+ structure AtomicState :
+ sig
+ datatype t = NonAtomic | Atomic of int
+ end
val atomicBegin: unit -> unit
val atomicEnd: unit -> unit
val atomically: (unit -> 'a) -> 'a
+ val atomicState: unit -> AtomicState.t
+
+ type 'a t
+
(* new f creates a new thread that will apply f to whatever is thrown
* to the thread. f must terminate by throwing to another thread or
* exiting the process.
@@ -32,6 +38,36 @@
* place).
*)
val switch': ('a t -> 'b t * (unit -> 'b)) -> 'a
+ (* atomicSwitch and atomicSwitch' are as above,
+ * but assume an atomic calling context.
+ *)
+ val atomicSwitch': ('a t -> 'b t * (unit -> 'b)) -> 'a
+ val atomicSwitch: ('a t -> 'b t * 'b) -> 'a
+
+ (*
+ (* One-shot continuations. *)
+ (* capture f
+ * Applies f to the current thread.
+ * If f returns or raises, then it implicitly escapes to the
+ * current thread.
+ *)
+ val capture: ('a t -> 'a) -> 'a
+ (* escape (t, x)
+ * Switch to t with argument x.
+ * It is illegal for another thread to later escape to t.
+ *)
+ val escape: 'a t * 'a -> 'b
+ (* escape' (t, th)
+ * Generalization of escape that evaluates the thunk th in the
+ * context of t (i.e., t's stack and exception handlers are in
+ * place).
+ *)
+ val escape': 'a t * (unit -> 'a) -> 'b
+
+ val atomicCapture: ('a t -> 'a) -> 'a
+ val atomicEscape: 'a t * 'a -> 'b
+ val atomicEscape': 'a t * (unit -> 'a) -> 'b
+ *)
end
signature MLTON_THREAD_EXTRA =
1.24 +230 -120 mlton/basis-library/mlton/thread.sml
Index: thread.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sml,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- thread.sml 30 Mar 2004 01:44:13 -0000 1.23
+++ thread.sml 2 Apr 2004 02:49:51 -0000 1.24
@@ -9,11 +9,20 @@
structure Prim = Primitive.Thread
+structure AtomicState =
+ struct
+ datatype t = NonAtomic | Atomic of int
+ end
+
local
open Prim
in
val atomicBegin = atomicBegin
val atomicEnd = atomicEnd
+ val atomicState = fn () =>
+ case canHandle () of
+ 0 => AtomicState.NonAtomic
+ | n => AtomicState.Atomic n
end
fun atomically f =
@@ -31,77 +40,167 @@
let
val t =
case !r of
- Dead => raise Fail "Thread.prepend"
+ Dead => raise Fail "prepend to a Dead thread"
| New g => New (g o f)
| Paused (g, t) => Paused (fn h => g (f o h), t)
in r := Dead
; T (ref t)
end
-datatype state =
- Normal
- | InHandler
-
-val state: state ref = ref Normal
-
-fun amInSignalHandler () = InHandler = !state
-
fun new f = T (ref (New f))
local
- val func: (unit -> unit) option ref = ref NONE
- val base: Prim.preThread =
- (Prim.copyCurrent ()
- ; (case !func of
- NONE => Prim.savedPre ()
- | SOME x =>
- (* This branch never returns. *)
- (func := NONE
- (* Close the atomicBegin of the thread that switched to me. *)
- ; 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)
+ local
+ val func: (unit -> unit) option ref = ref NONE
+ val base: Prim.preThread =
+ let
+ val () = Prim.copyCurrent ()
+ in
+ case !func of
+ NONE => Prim.savedPre ()
+ | SOME x =>
+ (* This branch never returns. *)
+ let
+ (* Atomic 1 *)
+ val () = func := NONE
+ val () = atomicEnd ()
+ (* Atomic 0 *)
+ in
+ (x () handle e => MLtonExn.topLevelHandler e)
+ ; die "Thread didn't exit properly.\n"
+ end
+ end
+ in
+ fun newThread (f: unit -> unit) : Prim.thread =
+ let
+ (* Atomic 2 *)
+ val () = func := SOME f
+ in
+ Prim.copy base
+ end
+ end
val switching = ref false
in
- fun ('a, 'b) switch'NoAtomicBegin (f: 'a t -> 'b t * (unit -> 'b)): 'a =
+ fun ('a, 'b) atomicSwitch' (f: 'a t -> 'b t * (unit -> 'b)): 'a =
+ (* Atomic 1 *)
if !switching
- then (atomicEnd ()
- ; raise Fail "nested Thread.switch")
+ then let
+ val () = atomicEnd ()
+ (* Atomic 0 *)
+ in
+ raise Fail "nested Thread.switch"
+ end
else
let
val _ = switching := true
- val r: (unit -> 'a) option ref = ref NONE
+ val r : (unit -> 'a) ref =
+ ref (fn () => die "Thread.atomicSwitch' didn't set r.\n")
val t: 'a thread ref =
- ref (Paused (fn x => r := SOME x, Prim.current ()))
+ ref (Paused (fn x => r := x, Prim.current ()))
fun fail e = (t := Dead
; switching := false
; atomicEnd ()
- ; raise e)
+ ; raise e)
val (T t': 'b t, x: unit -> 'b) = f (T t) handle e => fail e
val primThread =
- case !t' before (t' := Dead; switching := false) of
+ case !t' before t' := Dead of
Dead => fail (Fail "switch to a Dead thread")
- | New g => newThread (g o x)
+ | New g => (atomicBegin (); newThread (g o x))
| Paused (f, t) => (f x; t)
- val _ = Prim.switchTo primThread
- (* Close the atomicBegin of the thread that switched to me. *)
- val _ = atomicEnd ()
+ val _ = switching := false
+ (* Atomic 1 when Paused, Atomic 2 when New *)
+ val _ = Prim.switchTo primThread (* implicit atomicEnd() *)
+ (* Atomic 0 when resuming *)
in
- case !r of
- NONE => die "Thread.switch didn't set r.\n"
- | SOME v => (r := NONE; v ())
+ !r ()
end
+
fun switch' f =
(atomicBegin ()
- ; switch'NoAtomicBegin f)
+ ; atomicSwitch' f)
+
+(*
+ (* One-shot continuations. *)
+ fun 'a atomicEscape' (T t : 'a t, x : unit -> 'a) : 'b =
+ let
+ val switchee : Prim.thread =
+ case !t before t := Dead of
+ Dead => raise (Fail "escape to a Dead thread")
+ | New g => (atomicBegin (); newThread (g o x))
+ | Paused (f, t) => (f x; t)
+ in
+ Prim.switchTo switchee
+ ; die "Thread.atomicEscape' reached impossible.\n"
+ end
+ fun 'a atomicEscape (t : 'a t, v : 'a) : 'b =
+ atomicEscape' (t, fn () => v)
+ fun escape' (t, x) =
+ (atomicBegin ()
+ ; atomicEscape' (t, x))
+ fun escape (t, x) =
+ (atomicBegin ()
+ ; atomicEscape (t, x))
+
+ fun 'a atomicCapture (f: 'a t -> 'a) : 'a =
+ let
+ val r : (unit -> 'a) ref =
+ ref (fn () => die "Thread.atomicCapture didn't set r.\n")
+ val t : 'a t =
+ T (ref (Paused (fn x => r := x, Prim.current ())))
+ val switcher : Prim.thread =
+ (atomicBegin ()
+ ; newThread (fn () =>
+ let val v = f t
+ in escape (t, v)
+ end
+ handle e =>
+ escape' (t, fn () => raise e)))
+ val _ = Prim.switchTo switcher
+ in
+ !r ()
+ end
+ fun capture f =
+ (atomicBegin ()
+ ; atomicCapture f)
+
+ fun ('a, 'b) atomicSwitch' (f: 'a t -> 'b t * (unit -> 'b)): 'a =
+ if !switching
+ then (atomicEnd ()
+ ; raise Fail "nested Thread.switch")
+ else
+ let
+ val () = switching := true
+ fun finish v () = (switching := false; atomicEnd (); v ())
+ fun fail e = finish (fn () => raise e) ()
+ val v = capture (fn t =>
+ let val (t', v') = f t
+ in escape' (t', finish v')
+ end)
+ handle e => fail e
+ in
+ v
+ end
+*)
end
+fun atomicSwitch f =
+ atomicSwitch' (fn t => let val (t, x) = f t
+ in (t, fn () => x)
+ end)
fun switch f =
- switch' (fn t => let val (t, x) = f t
- in (t, fn () => x)
- end)
+ (atomicBegin ()
+ ; atomicSwitch f)
+
+
+fun fromPrimitive (t: Prim.thread): unit t =
+ let
+ fun f x =
+ x ()
+ handle _ =>
+ die "Asynchronous exceptions are not allowed.\n"
+ in
+ T(ref(Paused (f,t)))
+ end
fun toPrimitive (t as T r : unit t): Prim.thread =
case !r of
@@ -111,94 +210,105 @@
; f (fn () => ())
; t)
| New _ =>
- switch' (fn cur: Prim.thread t =>
- (t, fn () => switch (fn t => (cur, toPrimitive t))))
+ switch'
+ (fn cur: Prim.thread t =>
+ (t: unit t, fn () =>
+ switch
+ (fn t : unit t =>
+ (cur, toPrimitive t))))
-fun fromPrimitive (t: Prim.thread): unit t =
- T (ref (Paused
- (fn f => ((atomicEnd (); f ())
- handle _ =>
- die "Asynchronous exceptions are not allowed.\n"),
- t)))
-val signalHandler: Prim.thread option ref = ref NONE
+local
+ val signalHandler: Prim.thread option ref = ref NONE
+ datatype state = Normal | InHandler
+ val state: state ref = ref Normal
+in
+ fun amInSignalHandler () = InHandler = !state
-fun setHandler (f: unit t -> unit t): unit =
- let
- val _ = Primitive.installSignalHandler ()
- fun loop () =
- let
- (* s->canHandle == 1 *)
- val _ = state := InHandler
- val t = f (fromPrimitive (Prim.saved ()))
- val _ = state := Normal
- val _ = Prim.finishHandler ()
- val _ =
- switch'NoAtomicBegin
- (fn (T r) =>
- let
- val _ =
- case !r of
- Paused (f, _) => f (fn () => ())
- | _ => raise Fail "setHandler saw strange Paused"
- in
- (t, fn () => ())
- end)
- in
- loop ()
- end
- val p =
- toPrimitive
- (new (fn () => loop () handle e => MLtonExn.topLevelHandler e))
- val _ = signalHandler := SOME p
- in
- Prim.setHandler p
- end
+ fun setHandler (f: unit t -> unit t): unit =
+ let
+ val _ = Primitive.installSignalHandler ()
+ fun loop (): unit =
+ let
+ (* Atomic 1 *)
+ val _ = state := InHandler
+ val t = f (fromPrimitive (Prim.saved ()))
+ val _ = state := Normal
+ val _ = Prim.finishHandler ()
+ val _ =
+ atomicSwitch'
+ (fn (T r) =>
+ let
+ val _ =
+ case !r of
+ Paused (f, _) => f (fn () => ())
+ | _ => raise Fail "setHandler saw strange thread"
+ in
+ (t, fn () => ())
+ end) (* implicit atomicEnd () *)
+ in
+ loop ()
+ end
+ val p =
+ toPrimitive
+ (new (fn () => loop () handle e => MLtonExn.topLevelHandler e))
+ val _ = signalHandler := SOME p
+ in
+ Prim.setHandler p
+ end
+
+ fun switchToHandler () =
+ let
+ (* Atomic 0 *)
+ val () = Prim.startHandler () (* implicit atomicBegin() *)
+ (* Atomic 1 *)
+ val () = atomicBegin ()
+ (* Atomic 2 *)
+ in
+ case !signalHandler of
+ NONE => raise Fail "no signal handler installed"
+ | SOME t => Prim.switchTo t (* implicit atomicEnd() *)
+ end
+end
-val register: int * (unit -> unit) -> unit =
- let
- 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 () =>
+
+local
+
+in
+ val register: int * (unit -> unit) -> unit =
+ let
+ val exports = Array.array (Primitive.FFI.numExports, fn () =>
+ raise Fail "undefined export")
+ fun loop (): unit =
+ let
+ (* Atomic 2 *)
+ val t = Prim.saved ()
+ fun doit () =
let
+ (* Atomic 1 *)
val _ =
+ (* atomicEnd() after getting args *)
(Array.sub (exports, Primitive.FFI.getOp ()) ())
- handle e => (TextIO.output
- (TextIO.stdErr,
- "Call from C to SML raised exception.\n")
- ; MLtonExn.topLevelHandler e)
+ handle e =>
+ (TextIO.output
+ (TextIO.stdErr, "Call from C to SML raised exception.\n")
+ ; MLtonExn.topLevelHandler e)
+ (* atomicBegin() before putting res *)
+ (* Atomic 1 *)
val _ = Prim.setSaved t
- val _ = Prim.returnToC ()
+ val _ = Prim.returnToC () (* implicit atomicEnd() *)
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 (fn () =>
- (atomicBegin ()
- ; loop ()))))
- in
- fn (i, f) => Array.update (exports, i, f)
- end
-
-fun switchToHandler () =
- (Prim.startHandler ()
- ; (case !signalHandler of
- NONE => raise Fail "no signal handler installed"
- | SOME t => Prim.switchTo t))
-
+ end
+ val _ = Prim.switchTo (toPrimitive (new doit)) (* implicit atomicEnd() *)
+ in
+ loop ()
+ end
+ val p = toPrimitive (new (fn () => loop ()))
+ val _ = Prim.setCallFromCHandler p
+ in
+ fn (i, f) => Array.update (exports, i, f)
+ end
end
+end
1.8 +1 -2 mlton/include/c-main.h
Index: c-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-main.h,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- c-main.h 29 Aug 2003 00:25:20 -0000 1.7
+++ c-main.h 2 Apr 2004 02:49:52 -0000 1.8
@@ -16,7 +16,7 @@
fprintf (stderr, "MLton_callFromC() starting\n"); \
s = &gcState; \
s->savedThread = s->currentThread; \
- s->canHandle += 2; \
+ s->canHandle += 3; \
/* Switch to the C Handler thread. */ \
GC_switchToThread (s, s->callFromCHandler); \
nextFun = *(int*)(s->stackTop - WORD_SIZE); \
@@ -26,7 +26,6 @@
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.11 +1 -2 mlton/include/x86-main.h
Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-main.h 29 Aug 2003 00:25:20 -0000 1.10
+++ x86-main.h 2 Apr 2004 02:49:52 -0000 1.11
@@ -75,13 +75,12 @@
fprintf (stderr, "MLton_callFromC() starting\n"); \
s = &gcState; \
s->savedThread = s->currentThread; \
- s->canHandle += 2; \
+ s->canHandle += 3; \
/* Return to the C Handler thread. */ \
GC_switchToThread (s, s->callFromCHandler); \
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.65 +49 -34 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.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- ssa-to-rssa.fun 19 Mar 2004 04:40:07 -0000 1.64
+++ ssa-to-rssa.fun 2 Apr 2004 02:49:52 -0000 1.65
@@ -859,7 +859,10 @@
| Type.Real s => c (Const.real (RealX.zero s))
| Type.Word s => c (Const.word (WordX.zero s))
end
- val handlesSignals = ref false
+ val handlesSignals =
+ S.Program.hasPrim
+ (program, fn p =>
+ Prim.name p = Prim.Name.MLton_installSignalHandler)
fun translateStatementsTransfer (statements, ss, transfer) =
let
fun loop (i, ss, t): Statement.t vector * Transfer.t =
@@ -1237,9 +1240,7 @@
(case targ () of
NONE => move (Operand.bool true)
| SOME _ => primApp prim)
- | MLton_installSignalHandler =>
- (handlesSignals := true
- ; none ())
+ | MLton_installSignalHandler => none ()
| MLton_touch => none ()
| Pointer_getInt s => pointerGet (Type.Int s)
| Pointer_getPointer =>
@@ -1271,11 +1272,9 @@
(Vector.new1 (a 0),
refRep (Vector.sub (targs, 0)))
| Thread_atomicBegin =>
- (* assert (s->canHandle >= 0);
- * s->canHandle++;
- * if (s->signalIsPending)
- * s->limit = s->limitPlusSlop
- * - LIMIT_SLOP;
+ (* gcState.canHandle++;
+ * if (gcState.signalIsPending)
+ * gcState.limit = gcState.limitPlusSlop - LIMIT_SLOP;
*)
split
(Vector.new0 (), Kind.Jump, ss, fn l =>
@@ -1309,39 +1308,50 @@
{args = Vector.new0 (),
dst = l})}
in
- (bumpCanHandle 1,
- Transfer.ifInt
- (Operand.Runtime SignalIsPending,
- {falsee = l,
- truee = l'}))
+ if handlesSignals
+ then (bumpCanHandle 1,
+ Transfer.ifInt
+ (Operand.Runtime SignalIsPending,
+ {falsee = l,
+ truee = l'}))
+ else (bumpCanHandle 1,
+ Transfer.Goto
+ {args = Vector.new0 (),
+ dst = l})
end)
| Thread_atomicEnd =>
(* gcState.canHandle--;
- * assert(gcState.canHandle >= 0);
* if (gcState.signalIsPending
* and 0 == gcState.canHandle)
- * gcState.limit = 0;
+ * gc;
*)
split
(Vector.new0 (), Kind.Jump, ss, fn l =>
let
datatype z = datatype GCField.t
- val statements =
- Vector.new1
- (Statement.Move
- {dst = Operand.Runtime Limit,
- src =
- Operand.word
- (WordX.zero (WordSize.pointer ()))})
+ val func = CFunction.gc {maySwitchThreads = true}
+ val args =
+ Vector.new5
+ (Operand.GCState,
+ Operand.int (IntX.zero IntSize.default),
+ Operand.bool false,
+ Operand.File,
+ Operand.Line)
+ val l''' =
+ newBlock
+ {args = Vector.new0 (),
+ kind = Kind.CReturn {func = func},
+ statements = Vector.new0 (),
+ transfer = Goto {args = Vector.new0 (),
+ dst = l}}
val l'' =
newBlock
{args = Vector.new0 (),
kind = Kind.Jump,
- statements = statements,
- transfer =
- Transfer.Goto
- {args = Vector.new0 (),
- dst = l}}
+ statements = Vector.new0 (),
+ transfer = Transfer.CCall {args = args,
+ func = func,
+ return = SOME l'''}}
val l' =
newBlock
{args = Vector.new0 (),
@@ -1353,11 +1363,16 @@
{falsee = l'',
truee = l})}
in
- (bumpCanHandle ~1,
- Transfer.ifInt
- (Operand.Runtime SignalIsPending,
- {falsee = l,
- truee = l'}))
+ if handlesSignals
+ then (bumpCanHandle ~1,
+ Transfer.ifInt
+ (Operand.Runtime SignalIsPending,
+ {falsee = l,
+ truee = l'}))
+ else (bumpCanHandle ~1,
+ Transfer.Goto
+ {args = Vector.new0 (),
+ dst = l})
end)
| Thread_canHandle =>
move (Operand.Runtime GCField.CanHandle)
@@ -1517,7 +1532,7 @@
end
val functions = List.revMap (functions, translateFunction)
val p = Program.T {functions = functions,
- handlesSignals = !handlesSignals,
+ handlesSignals = handlesSignals,
main = main,
objectTypes = objectTypes}
val _ = Program.clear p
1.172 +28 -24 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.171
retrieving revision 1.172
diff -u -r1.171 -r1.172
--- gc.c 29 Mar 2004 01:08:38 -0000 1.171
+++ gc.c 2 Apr 2004 02:49:52 -0000 1.172
@@ -655,13 +655,13 @@
(uint) s->frontier,
s->frontier - s->nursery,
s->limitPlusSlop - s->frontier);
- fprintf (stream, "\tcanHandle = %d\n", s->canHandle);
+ fprintf (stream, "\tcanHandle = %d\n\tsignalsIsPending = %d\n", s->canHandle, s->signalIsPending);
fprintf (stderr, "\tcurrentThread = 0x%08x\n", (uint) s->currentThread);
- fprintf (stream, "\tstackBottom = 0x%08x\nstackTop - stackBottom = %u\nstackLimit - stackTop = %u\n",
+ fprintf (stream, "\tstackBottom = 0x%08x\n\tstackTop - stackBottom = %u\n\tstackLimit - stackTop = %u\n",
(uint)s->stackBottom,
s->stackTop - s->stackBottom,
(s->stackLimit - s->stackTop));
- fprintf (stream, "\texnStack = %u bytesNeeded = %u reserved = %u used = %u\n",
+ fprintf (stream, "\texnStack = %u\n\tbytesNeeded = %u\n\treserved = %u\n\tused = %u\n",
s->currentThread->exnStack,
s->currentThread->bytesNeeded,
s->currentThread->stack->reserved,
@@ -3059,10 +3059,28 @@
assert (s->currentThread->bytesNeeded <= s->limitPlusSlop - s->frontier);
}
+static void startHandler (GC_state s) {
+ /* Switch to the signal handler thread. */
+ if (DEBUG_SIGNALS) {
+ fprintf (stderr, "switching to signal handler\n");
+ GC_display (s, stderr);
+ }
+ assert (0 == s->canHandle);
+ assert (s->signalIsPending);
+ s->signalIsPending = FALSE;
+ s->inSignalHandler = TRUE;
+ s->savedThread = s->currentThread;
+ /* Set s->canHandle to 1 when switching to the signal handler thread,
+ * which will then run atomically and will finish by switching to
+ * the thread to continue with, which will decrement s->canHandle to 0.
+ */
+ s->canHandle = 1;
+}
+
void GC_switchToThread (GC_state s, GC_thread t) {
if (DEBUG_THREADS)
fprintf (stderr, "GC_switchToThread (0x%08x)\n", (uint)t);
- if (FALSE) {
+ if (TRUE) {
/* This branch is slower than the else branch, especially
* when debugging is turned on, because it does an invariant
* check on every thread switch.
@@ -3070,6 +3088,11 @@
*/
enter (s);
switchToThread (s, t);
+ s->canHandle--;
+ if (0 == s->canHandle and s->signalIsPending) {
+ startHandler(s);
+ switchToThread(s, s->signalHandler);
+ }
leave (s);
} else {
s->currentThread->stack->used = currentStackUsed (s);
@@ -3085,25 +3108,6 @@
assert (s->currentThread->bytesNeeded <= s->limitPlusSlop - s->frontier);
}
-static void startHandler (GC_state s) {
- /* Switch to the signal handler thread. */
- if (DEBUG_SIGNALS) {
- fprintf (stderr, "switching to signal handler\n");
- GC_display (s, stderr);
- }
- assert (0 == s->canHandle);
- assert (s->signalIsPending);
- s->signalIsPending = FALSE;
- s->inSignalHandler = TRUE;
- s->savedThread = s->currentThread;
- /* Set s->canHandle to 2, which will be decremented to 1
- * when switching to the signal handler thread, which will then
- * run atomically and will finish by switching to the thread
- * to continue with, which will decrement s->canHandle to 0.
- */
- s->canHandle = 2;
-}
-
/* GC_startHandler does not do an enter()/leave(), even though it is exported.
* The basis library uses it via _ffi, not _prim, and so does not treat it as a
* runtime call -- so the invariant in enter would fail miserably. It simulates
@@ -4536,7 +4540,7 @@
*/
void GC_handler (GC_state s, int signum) {
if (DEBUG_SIGNALS)
- fprintf (stderr, "GC_handler signum = %d\n", signum);
+ fprintf (stderr, "GC_handler signum = %d\n", signum);
assert (sigismember (&s->signalsHandled, signum));
if (0 == s->canHandle)
s->limit = 0;
1.12 +7 -2 mlton/runtime/basis/Thread.c
Index: Thread.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Thread.c,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- Thread.c 5 Jul 2003 23:30:26 -0000 1.11
+++ Thread.c 2 Apr 2004 02:49:52 -0000 1.12
@@ -9,7 +9,12 @@
};
Thread Thread_current () {
- return (Thread)gcState.currentThread;
+ Thread t;
+
+ t = (Thread)gcState.currentThread;
+ if (DEBUG_THREAD)
+ fprintf (stderr, "0x%08x = Thread_current ()\n", (uint)t);
+ return t;
}
void Thread_finishHandler () {
@@ -47,7 +52,7 @@
void Thread_switchTo (Thread thread, Word ensureBytesFree) {
GC_state s;
- if (FALSE)
+ if (DEBUG_THREAD)
fprintf (stderr, "Thread_switchTo (0x%08x, %u)\n",
(uint)thread, (uint)ensureBytesFree);
s = &gcState;