[MLton] cvs commit: better blocking/unblocking of signals in runtime and basis
Matthew Fluet
fluet@mlton.org
Tue, 13 Apr 2004 18:12:49 -0700
fluet 04/04/13 18:12:48
Modified: doc changelog
basis-library/mlton signal.sig signal.sml
basis-library/posix primitive.sml
doc/user-guide extensions.tex
lib/mlton-stubs mlton.sml signal.sig thread.sig thread.sml
runtime gc.c mlton-posix.h
runtime/Posix/Signal Signal.c
Log:
MAIL better blocking/unblocking of signals in runtime and basis
Keep gcState.signalsBlocked in sync with the user program.
To do so, we keep an ML side representation of the currently blocked
signals. Upon a MLton.Signal.Mask.{block,unblock,setBlocked}, we
compute the new set of blocked signals and call sigprocmask with
SIG_SETMASK. (Note, this eliminates PosixPrimitive.Signal.how.)
On the runtime side, the sigprocmask in unblockSignals uses
signalsBlocked with SIG_SETMASK.
Two things:
1) there is a race condition in calling sigprocmask and updating the
ML side representation; this will go away with
Posix.Error.sysCall.
2) MLton.Signal.Mask.getBlocked (and the ML side representation) do
not reflect the blocking of signals during the execution of a
signal handler. This is easily changed, but it seems more
natural this way.
Revision Changes Path
1.117 +3 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.116
retrieving revision 1.117
diff -u -r1.116 -r1.117
--- changelog 12 Apr 2004 23:41:33 -0000 1.116
+++ changelog 14 Apr 2004 01:12:38 -0000 1.117
@@ -1,5 +1,8 @@
Here are the changes since version 20040227.
+* 2004-04-13
+ - Added MLton.Signal.Mask.{getBlocked,member}.
+
* 2004-04-12
- Fix bug that mistakenly generalized variable types containing
unknown types when matching against a signature.
1.12 +2 -0 mlton/basis-library/mlton/signal.sig
Index: signal.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- signal.sig 11 Feb 2004 19:16:11 -0000 1.11
+++ signal.sig 14 Apr 2004 01:12:38 -0000 1.12
@@ -22,6 +22,8 @@
val all: t
val allBut: signal list -> t
val block: t -> unit
+ val getBlocked: unit -> t
+ val member: t * signal -> bool
val none: t
val setBlocked: t -> unit
val some: signal list -> t
1.27 +38 -8 mlton/basis-library/mlton/signal.sml
Index: signal.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sml,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- signal.sml 30 Mar 2004 01:44:01 -0000 1.26
+++ signal.sml 14 Apr 2004 01:12:38 -0000 1.27
@@ -17,8 +17,6 @@
val prof = Prim.prof
val vtalrm = Prim.vtalrm
-type how = Prim.how
-
(* val toString = SysWord.toString o toWord *)
val checkResult = Error.checkResult
@@ -35,6 +33,33 @@
val all = allBut []
val none = some []
+ local
+ fun member (sigs, s) = List.exists (fn s' => s = s') sigs
+ fun inter (sigs1, sigs2) =
+ List.filter (fn s => member (sigs2, s)) sigs1
+ fun diff (sigs1, sigs2) =
+ List.filter (fn s => not (member (sigs2, s))) sigs1
+ fun union (sigs1, sigs2) =
+ List.foldl (fn (s,sigs) => if member (sigs, s) then sigs else s::sigs) sigs1 sigs2
+ in
+ fun block (mask1, mask2) =
+ case (mask1, mask2) of
+ (AllBut sigs1, AllBut sigs2) => AllBut (inter (sigs1, sigs2))
+ | (AllBut sigs1, Some sigs2) => AllBut (diff (sigs1, sigs2))
+ | (Some sigs1, AllBut sigs2) => AllBut (diff (sigs2, sigs1))
+ | (Some sigs1, Some sigs2) => Some (union (sigs1, sigs2))
+ fun unblock (mask1, mask2) =
+ case (mask1, mask2) of
+ (AllBut sigs1, AllBut sigs2) => Some (diff (sigs2, sigs1))
+ | (AllBut sigs1, Some sigs2) => AllBut (union (sigs1, sigs2))
+ | (Some sigs1, AllBut sigs2) => Some (inter (sigs1, sigs2))
+ | (Some sigs1, Some sigs2) => Some (diff (sigs1, sigs2))
+ val member = fn (mask, s) =>
+ case mask of
+ AllBut sigs => not (member (sigs, s))
+ | Some sigs => member (sigs, s)
+ end
+
fun create m =
case m of
AllBut signals =>
@@ -43,14 +68,19 @@
| Some signals =>
(checkResult (Prim.sigemptyset ())
; List.app (checkResult o Prim.sigaddset) signals)
-
+
local
- fun make (how: how) (m: t) =
- (create m; checkResult (Prim.sigprocmask how))
+ val blocked = ref none
+
+ fun make (m: t) =
+ (create m
+ ; checkResult (Prim.sigprocmask ())
+ ; blocked := m)
in
- val block = make Prim.block
- val unblock = make Prim.unblock
- val setBlocked = make Prim.setmask
+ val block = fn m => make (block (!blocked, m))
+ val unblock = fn m => make (unblock (!blocked, m))
+ val setBlocked = fn m => make m
+ val getBlocked = fn () => !blocked
end
end
1.26 +1 -6 mlton/basis-library/posix/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/primitive.sml,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- primitive.sml 12 Apr 2004 17:41:45 -0000 1.25
+++ primitive.sml 14 Apr 2004 01:12:39 -0000 1.26
@@ -122,14 +122,12 @@
structure Signal:>
sig
eqtype t
- type how
val fromInt: int -> t
val toInt: t -> int
end =
struct
type t = int
- type how = int
val fromInt = fn s => s
val toInt = fn s => s
@@ -162,7 +160,6 @@
val usr2 = _const "Posix_Signal_usr2": t;
val vtalrm = _const "Posix_Signal_vtalrm": t;
- val block = _const "Posix_Signal_block": how;
val default = _import "Posix_Signal_default": t -> int;
val handleGC = _import "Posix_Signal_handleGC": unit -> unit;
val handlee = _import "Posix_Signal_handle": t -> int;
@@ -172,14 +169,12 @@
val isGCPending = _import "Posix_Signal_isGCPending": unit -> bool;
val isPending = _import "Posix_Signal_isPending": t -> bool;
val numSignals = _const "Posix_Signal_numSignals": int;
- val setmask = _const "Posix_Signal_setmask": how;
val sigaddset = _import "Posix_Signal_sigaddset": t -> int;
val sigdelset = _import "Posix_Signal_sigdelset": t -> int;
val sigemptyset = _import "Posix_Signal_sigemptyset": unit -> int;
val sigfillset = _import "Posix_Signal_sigfillset": unit -> int;
- val sigprocmask = _import "Posix_Signal_sigprocmask": how -> int;
+ val sigprocmask = _import "Posix_Signal_sigprocmask": unit -> int;
val suspend = _import "Posix_Signal_suspend": unit -> unit;
- val unblock = _const "Posix_Signal_unblock": how;
end
structure Process =
1.64 +29 -4 mlton/doc/user-guide/extensions.tex
Index: extensions.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/extensions.tex,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -r1.63 -r1.64
--- extensions.tex 29 Mar 2004 01:53:42 -0000 1.63
+++ extensions.tex 14 Apr 2004 01:12:39 -0000 1.64
@@ -785,6 +785,8 @@
val all: t
val allBut: signal list -> t
val block: t -> unit
+ val getBlocked: unit -> t
+ val member: t * signal -> bool
val none: t
val setBlocked: t -> unit
val some: signal list -> t
@@ -839,6 +841,13 @@
\entry{Mask.block m}
block all signals in {\tt m}.
+\entry{Mask.getBlocked ()}
+get the signal mask {\tt m}, i.e. a signal is blocked if and only
+if it is in {\tt m}.
+
+\entry{Mask.member (m, s)}
+returns true if the signal {\tt s} is in the {\tt m}.
+
\entry{Mask.none}
a mask of no signals.
@@ -1029,10 +1038,17 @@
\begin{verbatim}
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
+
val new: ('a -> unit) -> 'a t
val prepend: 'a t * ('b -> 'a) -> 'b t
val switch: ('a t -> 'b t * 'b) -> 'a
@@ -1042,14 +1058,23 @@
\begin{description}
-\entry{type 'a t}
-the type of threads that expect a value of type {\tt 'a}.
+\entry{type AtomicState.t}
+the type of atomic states.
\entry{atomicBegin ()}
begin a critical section.
\entry{atomicEnd ()}
end a critical section.
+
+\entry{atomically f}
+runs {\tt f} in a critical section.
+
+\entry{atomicState ()}
+return the current atomic state.
+
+\entry{type 'a t}
+the type of threads that expect a value of type {\tt 'a}.
\entry{new f}
create a new thread that, when run, applies {\tt f} to the
1.31 +2 -0 mlton/lib/mlton-stubs/mlton.sml
Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sml,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- mlton.sml 28 Feb 2004 03:34:57 -0000 1.30
+++ mlton.sml 14 Apr 2004 01:12:39 -0000 1.31
@@ -355,6 +355,8 @@
val all = ()
fun allBut _ = ()
fun block _ = raise Fail "block"
+ fun getBlocked _ = ()
+ fun member _ = raise Fail "member"
val none = ()
fun setBlocked _ = raise Fail "setBlocked"
fun some _ = ()
1.8 +2 -0 mlton/lib/mlton-stubs/signal.sig
Index: signal.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/signal.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- signal.sig 28 Feb 2004 01:55:14 -0000 1.7
+++ signal.sig 14 Apr 2004 01:12:47 -0000 1.8
@@ -22,6 +22,8 @@
val all: t
val allBut: signal list -> t
val block: t -> unit
+ val getBlocked: unit -> t
+ val member: t * signal -> bool
val none: t
val setBlocked: t -> unit
val some: signal list -> t
1.7 +11 -2 mlton/lib/mlton-stubs/thread.sig
Index: thread.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/thread.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- thread.sig 8 Jul 2003 01:29:37 -0000 1.6
+++ thread.sig 14 Apr 2004 01:12:47 -0000 1.7
@@ -1,9 +1,18 @@
+type int = Int.int
+
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.
1.3 +11 -2 mlton/lib/mlton-stubs/thread.sml
Index: thread.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/thread.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- thread.sml 8 Feb 2003 00:36:24 -0000 1.2
+++ thread.sml 14 Apr 2004 01:12:47 -0000 1.3
@@ -1,9 +1,18 @@
+type int = Int.int
+
structure MLtonThread =
struct
- type 'a t = unit
-
+ structure AtomicState =
+ struct
+ datatype t = NonAtomic | Atomic of int
+ end
val atomicBegin = fn _ => raise Fail "Thread.atomicBegin"
val atomicEnd = fn _ => raise Fail "Thread.atomicEnd"
+ val atomically = fn _ => raise Fail "Thread.atomically"
+ val atomicState = fn _ => raise Fail "Thread.atomicState"
+
+ type 'a t = unit
+
val new = fn _ => raise Fail "Thread.new"
val prepend = fn _ => raise Fail "Thread.prepend"
val switch = fn _ => raise Fail "Thread.switch"
1.176 +1 -1 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.175
retrieving revision 1.176
diff -u -r1.175 -r1.176
--- gc.c 9 Apr 2004 13:54:34 -0000 1.175
+++ gc.c 14 Apr 2004 01:12:48 -0000 1.176
@@ -1306,7 +1306,7 @@
static inline void blockSignals (GC_state s) {
if (shouldBlockSignals ())
- sigprocmask (SIG_BLOCK, &s->signalsHandled, &s->signalsBlocked);
+ sigprocmask (SIG_BLOCK, &s->signalsHandled, NULL);
}
static inline void unblockSignals (GC_state s) {
1.9 +1 -1 mlton/runtime/mlton-posix.h
Index: mlton-posix.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/mlton-posix.h,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- mlton-posix.h 4 Apr 2004 18:21:43 -0000 1.8
+++ mlton-posix.h 14 Apr 2004 01:12:48 -0000 1.9
@@ -189,7 +189,7 @@
Int Posix_Signal_sigdelset (Int signum);
Int Posix_Signal_sigemptyset ();
Int Posix_Signal_sigfillset ();
-Int Posix_Signal_sigprocmask (Int how);
+Int Posix_Signal_sigprocmask ();
Int Posix_Signal_sigsuspend ();
/* ------------------------------------------------- */
1.13 +9 -2 mlton/runtime/Posix/Signal/Signal.c
Index: Signal.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Signal/Signal.c,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- Signal.c 18 Aug 2003 06:19:53 -0000 1.12
+++ Signal.c 14 Apr 2004 01:12:48 -0000 1.13
@@ -85,8 +85,15 @@
return sigfillset (&set);
}
-Int Posix_Signal_sigprocmask (Int how) {
- return sigprocmask (how, &set, (sigset_t*)NULL);
+Int Posix_Signal_sigismember (Int signum) {
+ return sigismember (&set, signum);
+}
+
+Int Posix_Signal_sigprocmask () {
+ gcState.signalsBlocked = set;
+ if (gcState.inSignalHandler)
+ return 1;
+ return sigprocmask (SIG_SETMASK, &set, (sigset_t*)NULL);
}
void Posix_Signal_suspend () {