[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