[MLton] cvs commit: Added PosixError.SysCall structure.

Matthew Fluet fluet@mlton.org
Thu, 29 Apr 2004 18:07:16 -0700


fluet       04/04/29 18:07:15

  Modified:    basis-library/mlton signal.sig signal.sml
               basis-library/posix error.sig error.sml
  Log:
  MAIL Added PosixError.SysCall structure.
  
  There is a little bit of an ordering problem; in that SysCall.syscall
  wants access to MLton.Signal.Mask to block and unblock signals when in
  a critical section; on the other hand, MLton.Signal needs a lot of
  infrastructure to be implemented.  To handle it, PosixError.SysCall
  has a
    val blocker: (unit -> (unit -> unit)) ref
  that MLton.Signal.Mask updates with the correct function for blocking
  and unblocking.

Revision  Changes    Path
1.16      +1 -0      mlton/basis-library/mlton/signal.sig

Index: signal.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sig,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- signal.sig	29 Apr 2004 23:41:05 -0000	1.15
+++ signal.sig	30 Apr 2004 01:07:14 -0000	1.16
@@ -33,6 +33,7 @@
 
       val getHandler: t -> Handler.t
       val prof: t
+      val restart: bool ref
       val setHandler: t * Handler.t -> unit
       (* suspend m temporarily sets the signal mask to m and suspends until an
        * unmasked signal is received and handled, and then resets the mask.



1.32      +20 -11    mlton/basis-library/mlton/signal.sml

Index: signal.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sml,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- signal.sml	29 Apr 2004 23:41:05 -0000	1.31
+++ signal.sml	30 Apr 2004 01:07:14 -0000	1.32
@@ -11,6 +11,8 @@
 open Posix.Signal
 structure Prim = PosixPrimitive.Signal
 structure Error = PosixError
+structure SysCall = Error.SysCall
+val restart = SysCall.restartFlag
 
 type t = signal
 
@@ -21,8 +23,6 @@
 
 (* val toString = SysWord.toString o toWord *)
    
-val checkResult = Error.checkResult
-val checkReturnResult = Error.checkReturnResult
 fun raiseInval () =
    let
       open PosixError
@@ -52,7 +52,7 @@
 	 (Array.foldri
 	  (fn (i, b, sigs) =>
 	   if b
-	      then if checkReturnResult(Prim.sigismember(fromInt i)) = 1
+	      then if (Prim.sigismember(fromInt i)) = 1
 		      then (fromInt i)::sigs
 		      else sigs
 	      else sigs)
@@ -62,15 +62,15 @@
       fun write m =
 	 case m of
 	    AllBut signals =>
-	       (checkResult (Prim.sigfillset ())
-		; List.app (checkResult o Prim.sigdelset) signals)
+	       (SysCall.simple Prim.sigfillset
+		; List.app (fn s => SysCall.simple (fn () => Prim.sigdelset s)) signals)
 	  | Some signals =>
-	       (checkResult (Prim.sigemptyset ())
-		; List.app (checkResult o Prim.sigaddset) signals)
+	       (SysCall.simple Prim.sigemptyset
+		; List.app (fn s => SysCall.simple (fn () => Prim.sigaddset s)) signals)
 	       
       local
 	 fun make (how: how) (m: t) =
-	    (write m; checkResult (Prim.sigprocmask how))
+	    (write m; SysCall.simpleRestart (fn () => Prim.sigprocmask how))
       in
 	 val block = make Prim.block
 	 val unblock = make Prim.unblock
@@ -140,6 +140,15 @@
 	   case h of 
 	      Handler _ => (fromInt s)::sigs
 	    | _ => sigs) [] handlers)
+
+      val () =
+	 PosixError.SysCall.blocker :=
+	 (fn () => let
+		      val m = getBlocked ()
+		      val () = block (handled ())
+		   in
+		      fn () => setBlocked m
+		   end)
    end
    
 structure Handler =
@@ -202,16 +211,16 @@
     | (Default, Default) => ()
     | (_, Default) => 
 	 (setHandler (s, Default)
-	  ; checkResult (Prim.default s))
+	  ; SysCall.simpleRestart (fn () => Prim.default s))
     | (Handler _, Handler _) =>
 	 setHandler (s, h)
     | (_, Handler _) =>
 	 (setHandler (s, h)
-	  ; checkResult (Prim.handlee s))
+	  ; SysCall.simpleRestart (fn () => Prim.handlee s))
     | (Ignore, Ignore) => ()
     | (_, Ignore) => 
 	 (setHandler (s, Ignore)
-	  ; checkResult (Prim.ignore s))
+	  ; SysCall.simpleRestart (fn () => Prim.ignore s))
 
 fun suspend m =
    (Mask.write m



1.4       +11 -0     mlton/basis-library/posix/error.sig

Index: error.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/error.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- error.sig	4 Dec 2003 22:42:09 -0000	1.3
+++ error.sig	30 Apr 2004 01:07:15 -0000	1.4
@@ -71,4 +71,15 @@
       val getErrno: unit -> int
       val clearErrno: unit -> unit
       val error: unit -> 'a
+
+      structure SysCall :
+	 sig
+	    val blocker: (unit -> (unit -> unit)) ref
+	    val restartFlag: bool ref
+	    val simple: (unit -> int) -> unit
+	    val simpleRestart: (unit -> int) -> unit
+	    val simpleResult: (unit -> int) -> int
+	    val simpleResultRestart: (unit -> int) -> int
+	    val syscall: {restart: bool} * (unit -> int * (unit -> 'a)) -> 'a
+	 end
    end



1.8       +51 -0     mlton/basis-library/posix/error.sml

Index: error.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/error.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- error.sml	13 Feb 2004 17:05:55 -0000	1.7
+++ error.sml	30 Apr 2004 01:07:15 -0000	1.8
@@ -40,4 +40,55 @@
       fun checkReturnPosition (n: Position.int) =
 	 if n = ~1 then error () else n
       fun checkResult n = (ignore (checkReturnResult n); ())
+
+      structure SysCall =
+	 struct
+	    structure Thread = Primitive.Thread
+
+	    val blocker: (unit -> (unit -> unit)) ref =
+	       ref (fn () => raise Fail "blocker not installed")
+	    val restartFlag = ref true
+	       
+	    val syscall: {restart: bool} * 
+	                 (unit -> int * (unit -> 'a)) -> 'a =
+	       fn ({restart}, f) =>
+	       let
+		  fun call (err: int -> 'a): 'a =
+		     let
+			val () = Thread.atomicBegin ()
+			val (n, post) = f ()
+		     in
+			if n = ~1
+			   then let val e = getErrno ()
+				in Thread.atomicEnd () ; err e
+				end
+			   else (post () before Thread.atomicEnd ())
+		     end
+		  fun err (e: int): 'a =
+		     if restart andalso e = intr andalso !restartFlag
+			then if Thread.canHandle () = 0
+				then call err
+				else let val finish = !blocker ()
+				     in
+					DynamicWind.wind
+					(fn () => call raiseSys, finish)
+				     end
+			else raiseSys e
+	       in
+		  call err
+	       end
+
+	    local
+	       val simpleResult' = fn ({restart}, f) =>
+		  syscall ({restart = restart}, fn () => let val n = f () in (n, fn () => n) end)
+	    in
+	       val simpleResultRestart = fn f =>
+		  simpleResult' ({restart = true}, f)
+	       val simpleResult = fn f =>
+		  simpleResult' ({restart = false}, f)
+	    end
+
+	    val simpleRestart = ignore o simpleResultRestart
+	    val simple = ignore o simpleResult
+	 end
    end