Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2015 Matthew Fluet. |
2 | * Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | structure MLtonSignal: MLTON_SIGNAL_EXTRA = | |
11 | struct | |
12 | ||
13 | open Posix.Signal | |
14 | structure Prim = PrimitiveFFI.Posix.Signal | |
15 | structure Error = PosixError | |
16 | structure SysCall = Error.SysCall | |
17 | val restart = SysCall.restartFlag | |
18 | ||
19 | type t = signal | |
20 | ||
21 | type how = C_Int.t | |
22 | ||
23 | fun raiseInval () = | |
24 | let | |
25 | open PosixError | |
26 | in | |
27 | raiseSys inval | |
28 | end | |
29 | ||
30 | structure Mask = | |
31 | struct | |
32 | type pre_sig_set = Word8.word array | |
33 | type sig_set = Word8.word vector | |
34 | fun newSigSet (): (pre_sig_set * (unit -> sig_set)) = | |
35 | let | |
36 | val sslen = C_Size.toInt Prim.sigSetLen | |
37 | val ss = Array.array (sslen, 0wx0: Word8.word) | |
38 | in | |
39 | (ss, fn () => Array.vector ss) | |
40 | end | |
41 | ||
42 | type t = sig_set | |
43 | ||
44 | fun allBut sigs = | |
45 | let | |
46 | val (ss, finish) = newSigSet () | |
47 | val () = SysCall.simple (fn () => Prim.sigfillset ss) | |
48 | val () = List.app (fn s => SysCall.simple | |
49 | (fn () => Prim.sigdelset (ss, toRep s))) | |
50 | sigs | |
51 | in | |
52 | finish () | |
53 | end | |
54 | val all = allBut [] | |
55 | fun some sigs = | |
56 | let | |
57 | val (ss, finish) = newSigSet () | |
58 | val () = SysCall.simple (fn () => Prim.sigemptyset ss) | |
59 | val () = List.app (fn s => SysCall.simple | |
60 | (fn () => Prim.sigaddset (ss, toRep s))) | |
61 | sigs | |
62 | in | |
63 | finish () | |
64 | end | |
65 | val none = some [] | |
66 | ||
67 | fun isMember (ss, s) = | |
68 | SysCall.simpleResult (fn () => Prim.sigismember (ss, toRep s)) <> C_Int.zero | |
69 | ||
70 | local | |
71 | fun make (how: how) (ss: t) = | |
72 | let | |
73 | val (oss, finish) = newSigSet () | |
74 | val () = SysCall.simpleRestart (fn () => Prim.sigprocmask (how, ss, oss)) | |
75 | in | |
76 | finish () | |
77 | end | |
78 | in | |
79 | val block = ignore o make Prim.SIG_BLOCK | |
80 | val unblock = ignore o make Prim.SIG_UNBLOCK | |
81 | val setBlocked = ignore o make Prim.SIG_SETMASK | |
82 | fun getBlocked () = make Prim.SIG_BLOCK none | |
83 | end | |
84 | end | |
85 | ||
86 | structure Handler = | |
87 | struct | |
88 | datatype t = | |
89 | Default | |
90 | | Handler of MLtonThread.Runnable.t -> MLtonThread.Runnable.t | |
91 | | Ignore | |
92 | | InvalidSignal | |
93 | end | |
94 | ||
95 | datatype handler = datatype Handler.t | |
96 | ||
97 | local | |
98 | val r = ref C_Int.zero | |
99 | in | |
100 | fun initHandler (s: signal): Handler.t = | |
101 | SysCall.syscallErr | |
102 | ({clear = false, restart = false, errVal = C_Int.fromInt ~1}, fn () => | |
103 | {return = Prim.isDefault (toRep s, r), | |
104 | post = fn _ => if !r <> C_Int.zero then Default else Ignore, | |
105 | handlers = [(Error.inval, fn () => InvalidSignal)]}) | |
106 | end | |
107 | ||
108 | val (getHandler, setHandler, handlers) = | |
109 | let | |
110 | val handlers = Array.tabulate (C_Int.toInt Prim.NSIG, initHandler o fromInt) | |
111 | val _ = | |
112 | Cleaner.addNew | |
113 | (Cleaner.atLoadWorld, fn () => | |
114 | Array.modifyi (initHandler o fromInt o #1) handlers) | |
115 | in | |
116 | (fn s: t => Array.sub (handlers, toInt s), | |
117 | fn (s: t, h) => if Primitive.MLton.Profile.isOn andalso s = prof | |
118 | then raiseInval () | |
119 | else Array.update (handlers, toInt s, h), | |
120 | handlers) | |
121 | end | |
122 | ||
123 | val gcHandler = ref Ignore | |
124 | ||
125 | fun handled () = | |
126 | Mask.some | |
127 | (Array.foldri | |
128 | (fn (s, h, sigs) => | |
129 | case h of | |
130 | Handler _ => (fromInt s)::sigs | |
131 | | _ => sigs) [] handlers) | |
132 | ||
133 | structure Handler = | |
134 | struct | |
135 | open Handler | |
136 | ||
137 | val default = Default | |
138 | val ignore = Ignore | |
139 | ||
140 | val isDefault = fn Default => true | _ => false | |
141 | val isIgnore = fn Ignore => true | _ => false | |
142 | ||
143 | val handler = | |
144 | (* This let is used so that Thread.setHandler is only used if | |
145 | * Handler.handler is used. This prevents threads from being part | |
146 | * of every program. | |
147 | *) | |
148 | let | |
149 | (* As far as C is concerned, there is only one signal handler. | |
150 | * As soon as possible after a C signal is received, this signal | |
151 | * handler walks over the array of all SML handlers, and invokes any | |
152 | * one for which a C signal has been received. | |
153 | * | |
154 | * Any exceptions raised by a signal handler will be caught by | |
155 | * the topLevelHandler, which is installed in thread.sml. | |
156 | *) | |
157 | val _ = | |
158 | PosixError.SysCall.blocker := | |
159 | (fn () => let | |
160 | val m = Mask.getBlocked () | |
161 | val () = Mask.block (handled ()) | |
162 | in | |
163 | fn () => Mask.setBlocked m | |
164 | end) | |
165 | ||
166 | val () = | |
167 | MLtonThread.setSignalHandler | |
168 | (fn t => | |
169 | let | |
170 | val mask = Mask.getBlocked () | |
171 | val () = Mask.block (handled ()) | |
172 | val fs = | |
173 | case !gcHandler of | |
174 | Handler f => if Prim.isPendingGC () <> C_Int.zero | |
175 | then [f] | |
176 | else [] | |
177 | | _ => [] | |
178 | val fs = | |
179 | Array.foldri | |
180 | (fn (s, h, fs) => | |
181 | case h of | |
182 | Handler f => | |
183 | if Prim.isPending (repFromInt s) <> C_Int.zero | |
184 | then f::fs | |
185 | else fs | |
186 | | _ => fs) fs handlers | |
187 | val () = Prim.resetPending () | |
188 | val () = Mask.setBlocked mask | |
189 | in | |
190 | List.foldl (fn (f, t) => f t) t fs | |
191 | end) | |
192 | in | |
193 | Handler | |
194 | end | |
195 | ||
196 | fun simple (f: unit -> unit) = handler (fn t => (f (); t)) | |
197 | end | |
198 | ||
199 | val setHandler = fn (s, h) => | |
200 | case (getHandler s, h) of | |
201 | (InvalidSignal, _) => raiseInval () | |
202 | | (_, InvalidSignal) => raiseInval () | |
203 | | (Default, Default) => () | |
204 | | (_, Default) => | |
205 | (setHandler (s, Default) | |
206 | ; SysCall.simpleRestart (fn () => Prim.default (toRep s))) | |
207 | | (Handler _, Handler _) => | |
208 | setHandler (s, h) | |
209 | | (_, Handler _) => | |
210 | (setHandler (s, h) | |
211 | ; SysCall.simpleRestart (fn () => Prim.handlee (toRep s))) | |
212 | | (Ignore, Ignore) => () | |
213 | | (_, Ignore) => | |
214 | (setHandler (s, Ignore) | |
215 | ; SysCall.simpleRestart (fn () => Prim.ignore (toRep s))) | |
216 | ||
217 | fun suspend m = | |
218 | (Prim.sigsuspend m | |
219 | ; MLtonThread.switchToSignalHandler ()) | |
220 | ||
221 | fun handleGC f = | |
222 | (Prim.handleGC () | |
223 | ; gcHandler := Handler.simple f) | |
224 | ||
225 | end |