[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 () {