[MLton] cvs commit: restructure of signal handling

Matthew Fluet fluet@mlton.org
Wed, 28 Apr 2004 19:59:00 -0700


fluet       04/04/28 19:58:59

  Modified:    basis-library/mlton signal.sig signal.sml thread.sml
               basis-library/posix primitive.sml
               bin      regression
               runtime  Makefile gc.c gc.h mlton-basis.h mlton-posix.h
               runtime/Posix/Signal Signal.c
  Added:       runtime/Posix/Signal resetPending.c
  Log:
  MAIL restructure of signal handling
  
  This checkin moves the entire process of blocking and unblocking of
  signals during a signal handler to the ML side.  Signals are only
  blocked while extracting the set of handlers from the
  gcState.pendingSignals sigset.  No user code is run while signals are
  blocked.
  
  The enter/leave functions of gc.c are also modified to treat runtime
  functions as running in a critical section (i.e., with canHandle++ in
  enter and canHandle-- in leave); this prevents limit from being
  modified while in the runtime.  If a signal is caught on the C side
  while in the GC, the limit will be reset to 0 during leave.

Revision  Changes    Path
1.14      +3 -0      mlton/basis-library/mlton/signal.sig

Index: signal.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sig,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- signal.sig	15 Apr 2004 13:02:13 -0000	1.13
+++ signal.sig	29 Apr 2004 02:58:58 -0000	1.14
@@ -3,6 +3,8 @@
       type t
       type signal = t
 
+      val sigismember : signal -> int;
+
       structure Handler:
 	 sig
 	    type t
@@ -31,6 +33,7 @@
 	 end
 
       val getHandler: t -> Handler.t
+      val handlers: Handler.t array
       val prof: t
       val setHandler: t * Handler.t -> unit
       (* suspend m temporarily sets the signal mask to m and suspends until an



1.30      +66 -57    mlton/basis-library/mlton/signal.sml

Index: signal.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sml,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- signal.sml	15 Apr 2004 13:14:54 -0000	1.29
+++ signal.sml	29 Apr 2004 02:58:58 -0000	1.30
@@ -14,12 +14,28 @@
 
 type t = signal
 
+val sigismember = Prim.sigismember
+
 val prof = Prim.prof
 val vtalrm = Prim.vtalrm
 
+type how = Prim.how
+
 (* val toString = SysWord.toString o toWord *)
    
 val checkResult = Error.checkResult
+val checkReturnResult = Error.checkReturnResult
+fun raiseInval () =
+   let
+      open PosixError
+   in
+      raiseSys inval
+   end
+
+val validSignals = 
+   Array.tabulate 
+   (Prim.numSignals, fn i => 
+    Prim.sigismember(fromInt i) <> ~1)
 
 structure Mask =
    struct
@@ -33,34 +49,19 @@
       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))
-	 fun isMember (mask, s) =
-	    case mask of
-	       AllBut sigs => not (member (sigs, s))
-	     | Some sigs => member (sigs, s)
-      end
+      fun read () =
+	 Some
+	 (Array.foldri
+	  (fn (i, b, sigs) =>
+	   if b
+	      then if checkReturnResult(Prim.sigismember(fromInt i)) = 1
+		      then (fromInt i)::sigs
+		      else sigs
+	      else sigs)
+	  []
+	  validSignals)
 
-      fun create m =
+      fun write m =
 	 case m of
 	    AllBut signals =>
 	       (checkResult (Prim.sigfillset ())
@@ -70,17 +71,24 @@
 		; List.app (checkResult o Prim.sigaddset) signals)
 	       
       local
-	 val blocked = ref none
-	    
-	 fun make (m: t) =
-	    (create m
-	     ; checkResult (Prim.sigprocmask ())
-	     ; blocked := m)
+	 fun make (how: how) (m: t) =
+	    (write m; checkResult (Prim.sigprocmask how))
       in
-	 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
+	 val block = make Prim.block
+	 val unblock = make Prim.unblock
+	 val setBlocked = make Prim.setmask
+	 fun getBlocked () = (make Prim.block none; read ())
+      end
+
+      local
+	 fun member (sigs, s) = List.exists (fn s' => s = s') sigs
+      in
+	 fun isMember (mask, s) =
+	    if Array.sub (validSignals, toInt s)
+	       then case mask of
+		       AllBut sigs => not (member (sigs, s))
+		     | Some sigs => member (sigs, s)		  
+	       else raiseInval ()
       end
    end
 
@@ -106,13 +114,6 @@
       else InvalidSignal
 end
 
-fun raiseInval () =
-   let
-      open PosixError
-   in
-      raiseSys inval
-   end
-
 val (getHandler, set, handlers) =
    let
       val handlers = Array.tabulate (Prim.numSignals, initHandler o fromInt)
@@ -158,21 +159,29 @@
 	       MLtonThread.setHandler
 	       (fn t =>
 		let
-		   val t =
-		      Array.foldli
-		      (fn (s, h, t) =>
+		   val mask = Mask.getBlocked ()
+		   val () =
+		      (Mask.block o Mask.some)
+		      (Array.foldri
+		       (fn (s, h, sigs) =>
+			case h of 
+			   Handler _ => (fromInt s)::sigs
+			 | _ => sigs) [] handlers)
+		   val fs = 
+		      case !gcHandler of
+			 Handler f => if Prim.isGCPending () then [f] else []
+		       | _ => []
+		   val fs =
+		      Array.foldri
+		      (fn (s, h, fs) =>
 		       case h of
 			  Handler f =>
-			     if Prim.isPending (fromInt s) then f t else t
-			| _ => t)
-		      t
-		      handlers
-		   val t =
-		      case !gcHandler of
-			 Handler f => if Prim.isGCPending () then f t else t
-		       | _ => t
+			     if Prim.isPending (fromInt s) then f::fs else fs
+			| _ => fs) fs handlers
+		   val () = Prim.resetPending ()
+		   val () = Mask.setBlocked mask
 		in
-		   t
+		   List.foldl (fn (f, t) => f t) t fs
 		end)
 	 in
 	    Handler
@@ -200,7 +209,7 @@
 	  ; checkResult (Prim.ignore s))
 
 fun suspend m =
-   (Mask.create m
+   (Mask.write m
     ; Prim.suspend ()
     ; MLtonThread.switchToHandler ())
 



1.25      +1 -1      mlton/basis-library/mlton/thread.sml

Index: thread.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sml,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- thread.sml	2 Apr 2004 02:49:51 -0000	1.24
+++ thread.sml	29 Apr 2004 02:58:58 -0000	1.25
@@ -224,7 +224,7 @@
    val state: state ref = ref Normal
 in
    fun amInSignalHandler () = InHandler = !state
-   
+
    fun setHandler (f: unit t -> unit t): unit =
       let
 	 val _ = Primitive.installSignalHandler ()



1.27      +8 -1      mlton/basis-library/posix/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/primitive.sml,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- primitive.sml	14 Apr 2004 01:12:39 -0000	1.26
+++ primitive.sml	29 Apr 2004 02:58:58 -0000	1.27
@@ -122,12 +122,14 @@
       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
@@ -160,6 +162,7 @@
 	    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;
@@ -169,12 +172,16 @@
 	    val isGCPending = _import "Posix_Signal_isGCPending": unit -> bool;
 	    val isPending = _import "Posix_Signal_isPending": t -> bool;
 	    val numSignals = _const "Posix_Signal_numSignals": int;
+	    val resetPending = _import "Posix_Signal_resetPending": unit -> unit;
+	    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": unit -> int;
+	    val sigismember = _import "Posix_Signal_sigismember": t -> int;
+	    val sigprocmask = _import "Posix_Signal_sigprocmask": how -> int;
 	    val suspend = _import "Posix_Signal_suspend": unit -> unit;
+	    val unblock = _const "Posix_Signal_unblock": how;
 	 end
       
       structure Process =



1.78      +2 -2      mlton/bin/regression

Index: regression
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/regression,v
retrieving revision 1.77
retrieving revision 1.78
diff -u -r1.77 -r1.78
--- regression	27 Apr 2004 08:15:10 -0000	1.77
+++ regression	29 Apr 2004 02:58:58 -0000	1.78
@@ -59,9 +59,9 @@
 if [ $cross = 'yes' ]; then
 	flags="$flags -target $crossTarget -stop g"
 fi
-cont='callcc.sml callcc2.sml callcc3.sml'
+cont='callcc.sml callcc2.sml callcc3.sml once.sml'
 intInf='conv.sml conv2.sml harmonic.sml int-inf.*.sml slow.sml slower.sml smith-normal-form.sml'
-signal='finalize.sml signals.sml signals2.sml suspend.sml'
+signal='finalize.sml signals.sml signals2.sml suspend.sml weak.sml'
 thread='thread0.sml thread1.sml thread2.sml mutex.sml prodcons.sml same-fringe.sml timeout.sml'
 world='world1.sml world2.sml world3.sml world4.sml world5.sml world6.sml'
 tmp=/tmp/z.regression.$$



1.80      +2 -0      mlton/runtime/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.79
retrieving revision 1.80
diff -u -r1.79 -r1.80
--- Makefile	4 Apr 2004 18:21:42 -0000	1.79
+++ Makefile	29 Apr 2004 02:58:58 -0000	1.80
@@ -180,6 +180,7 @@
 	Posix/Process/waitpid.o			\
 	Posix/Signal/Signal.o			\
 	Posix/Signal/isPending.o		\
+	Posix/Signal/resetPending.o		\
 	Posix/SysDB/Group.o			\
 	Posix/SysDB/Passwd.o			\
 	Posix/TTY/Termios.o			\
@@ -345,6 +346,7 @@
 	Posix/Process/waitpid-gdb.o		\
 	Posix/Signal/Signal-gdb.o		\
 	Posix/Signal/isPending-gdb.o		\
+	Posix/Signal/resetPending-gdb.o		\
 	Posix/SysDB/Group-gdb.o			\
 	Posix/SysDB/Passwd-gdb.o		\
 	Posix/TTY/Termios-gdb.o			\



1.178     +21 -48    mlton/runtime/gc.c

Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.177
retrieving revision 1.178
diff -u -r1.177 -r1.178
--- gc.c	26 Apr 2004 01:15:12 -0000	1.177
+++ gc.c	29 Apr 2004 02:58:58 -0000	1.178
@@ -1290,37 +1290,13 @@
 }
 #endif /* #if ASSERT */
 
-/* The purpose of blocking signals in GC is to prevent GC_handler from running,
- * which would muck with s->limit.  However, if the program doesn't handle 
- * signals, we don't need to block them.  This can be tested via the weak symbol
- * Posix_Signal_handle.
- */
-#if SUPPORTS_WEAK
-void Posix_Signal_handle () __attribute__ ((weak)); 
-#else
-void Posix_Signal_handle ();
-#endif
-static inline bool shouldBlockSignals () {
-	return 0 != Posix_Signal_handle;
-}
-
-static inline void blockSignals (GC_state s) {
-	if (shouldBlockSignals ())
-		sigprocmask (SIG_BLOCK, &s->signalsHandled, NULL);
-}
-
-static inline void unblockSignals (GC_state s) {
-	if (shouldBlockSignals ())
-		sigprocmask (SIG_SETMASK, &s->signalsBlocked, NULL);
-}
-
 /* ---------------------------------------------------------------- */
 /*                         enter and leave                          */
 /* ---------------------------------------------------------------- */
 
 /* enter and leave should be called at the start and end of every GC function
- * that is exported to the outside world.  They make sure that signals are
- * blocked for the duration of the function and check the GC invariant
+ * that is exported to the outside world.  They make sure that the function
+ * is run in a critical section and check the GC invariant.
  * They are a bit tricky because of the case when the runtime system is invoked
  * from within an ML signal handler.
  */
@@ -1332,8 +1308,8 @@
 	s->currentThread->exnStack = s->exnStack;
 	if (DEBUG) 
 		GC_display (s, stderr);
+	s->canHandle++;
 	unless (s->inSignalHandler) {
-		blockSignals (s);
 		if (0 == s->limit)
 			s->limit = s->limitPlusSlop - LIMIT_SLOP;
 	}
@@ -1349,10 +1325,9 @@
 	 * for functions that don't ensureBytesFree.
 	 */
 	assert (mutatorInvariant (s, FALSE, TRUE));
-	if (s->canHandle == 0 and s->signalIsPending)
+	if (s->canHandle == 1 and s->signalIsPending)
 		s->limit = 0;
-	unless (s->inSignalHandler)
-		unblockSignals (s);
+	s->canHandle--;
 	if (DEBUG)
 		fprintf (stderr, "leave ok\n");
 }
@@ -3106,16 +3081,18 @@
 		fprintf (stderr, "switching to signal handler\n");
 		GC_display (s, stderr);
 	}
-	assert (s->canHandle == 0);
+	assert (s->canHandle == 1);
 	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.
+	/* Set s->canHandle to 2 when switching to the signal handler thread;
+	 * leaving the runtime will decrement s->canHandle to 1,
+         * the signal handler 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;
+	s->canHandle = 2;
 }
 
 void GC_switchToThread (GC_state s, GC_thread t, uint ensureBytesFree) {
@@ -3131,7 +3108,7 @@
 		s->currentThread->bytesNeeded = ensureBytesFree;
 		switchToThread (s, t);
 		s->canHandle--;
-		if (s->canHandle == 0 and s->signalIsPending) {
+		if (s->canHandle == 1 and s->signalIsPending) {
 			startHandler (s);
 			switchToThread (s, s->signalHandler);
 		}
@@ -3143,8 +3120,8 @@
 		/* BEGIN: enter(s); */
 		s->currentThread->stack->used = currentStackUsed (s);
 		s->currentThread->exnStack = s->exnStack;
+		s->canHandle++;
 		unless (s->inSignalHandler) {
-			blockSignals (s);
 			if (0 == s->limit)
 				s->limit = s->limitPlusSlop - LIMIT_SLOP;
 		}
@@ -3152,7 +3129,7 @@
 		s->currentThread->bytesNeeded = ensureBytesFree;
 		switchToThread (s, t);
 		s->canHandle--;
-		if (s->canHandle == 0 and s->signalIsPending) {
+		if (s->canHandle == 1 and s->signalIsPending) {
 			startHandler (s);
 			switchToThread (s, s->signalHandler);
 		}
@@ -3166,8 +3143,7 @@
 		/* END: ensureMutatorInvariant */
 		else {
 		/* BEGIN: leave(s); */
-		unless (s->inSignalHandler)
-			unblockSignals (s);
+		s->canHandle--;
 		/* END: leave(s); */
 		}
 	}
@@ -3178,15 +3154,15 @@
 /* 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
- * the relevant part of enter() by blocking signals and resetting the limit.
- * The leave() wouldn't do anything upon exit because we are in a signal
- * handler.
+ * the relevant part of enter() by incrementing s->canHandle and resetting the 
+ * limit; it simulates the leave by decrementing s->canHandle.
  */
 void GC_startHandler (GC_state s) {
-	blockSignals (s);
+	s->canHandle++;
 	if (0 == s->limit)
 		s->limit = s->limitPlusSlop - LIMIT_SLOP;
 	startHandler (s);
+	s->canHandle--;
 }
 
 void GC_gc (GC_state s, uint bytesRequested, bool force,
@@ -3200,7 +3176,7 @@
 	if (0 == bytesRequested)
 		bytesRequested = LIMIT_SLOP;
 	s->currentThread->bytesNeeded = bytesRequested;
-	if (s->canHandle == 0 and s->signalIsPending) {
+	if (s->canHandle == 1 and s->signalIsPending) {
 		startHandler(s);
 		switchToThread (s, s->signalHandler);
 	}
@@ -4595,9 +4571,6 @@
 		fprintf (stderr, "GC_finishHandler ()\n");
 	assert (s->canHandle == 1);
 	s->inSignalHandler = FALSE;	
-	sigemptyset (&s->signalsPending);
-	s->gcSignalIsPending = FALSE;
-	unblockSignals (s);
 }
 
 /* GC_handler sets s->limit = 0 so that the next limit check will fail. 



1.74      +4 -0      mlton/runtime/gc.h

Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -r1.73 -r1.74
--- gc.h	7 Apr 2004 00:47:47 -0000	1.73
+++ gc.h	29 Apr 2004 02:58:58 -0000	1.74
@@ -556,6 +556,10 @@
  */
 void GC_done (GC_state s);
 
+/* GC_resetSignals should be called by the mutator signal handler thread when
+ * it is fetching the pending signals.
+ */
+void GC_resetSignals (GC_state s);
 
 /* GC_finishHandler should be called by the mutator signal handler thread when
  * it is done handling the signal.



1.31      +1 -0      mlton/runtime/mlton-basis.h

Index: mlton-basis.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/mlton-basis.h,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- mlton-basis.h	4 Apr 2004 18:21:43 -0000	1.30
+++ mlton-basis.h	29 Apr 2004 02:58:58 -0000	1.31
@@ -200,6 +200,7 @@
 
 Thread Thread_current ();
 void Thread_finishHandler ();
+void Thread_resetSignals ();
 Thread Thread_saved ();
 void Thread_setHandler (Thread t);
 void Thread_startHandler ();



1.10      +1 -1      mlton/runtime/mlton-posix.h

Index: mlton-posix.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/mlton-posix.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- mlton-posix.h	14 Apr 2004 01:12:48 -0000	1.9
+++ mlton-posix.h	29 Apr 2004 02:58:58 -0000	1.10
@@ -189,7 +189,7 @@
 Int Posix_Signal_sigdelset (Int signum);
 Int Posix_Signal_sigemptyset ();
 Int Posix_Signal_sigfillset ();
-Int Posix_Signal_sigprocmask ();
+Int Posix_Signal_sigprocmask (Int how);
 Int Posix_Signal_sigsuspend ();
 
 /* ------------------------------------------------- */



1.15      +2 -5      mlton/runtime/Posix/Signal/Signal.c

Index: Signal.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Signal/Signal.c,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- Signal.c	15 Apr 2004 13:02:13 -0000	1.14
+++ Signal.c	29 Apr 2004 02:58:59 -0000	1.15
@@ -89,11 +89,8 @@
 	return sigismember (&set, signum);
 }
 
-Int Posix_Signal_sigprocmask () {
-	gcState.signalsBlocked = set;
-	if (gcState.inSignalHandler)
-		return 0;
-	return sigprocmask (SIG_SETMASK, &set, (sigset_t*)NULL);
+Int Posix_Signal_sigprocmask (Int how) {
+	return sigprocmask (how, &set, &set);
 }
 
 void Posix_Signal_suspend () {



1.1                  mlton/runtime/Posix/Signal/resetPending.c

Index: resetPending.c
===================================================================
#include <signal.h>
#include "gc.h"
#include "mlton-posix.h"

enum {
	DEBUG_SIGNALS = FALSE,
};

extern struct GC_state gcState;

bool Posix_Signal_resetPending () {
	if (DEBUG_SIGNALS)
		fprintf (stderr, "Posix_Signal_resetPending ()\n");
	sigemptyset (&gcState.signalsPending);
	gcState.gcSignalIsPending = FALSE;
}