Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/system/Basis/Implementation/NJ/internal-signals.sml
ViewVC logotype

Annotation of /sml/trunk/src/system/Basis/Implementation/NJ/internal-signals.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 842 - (view) (download)

1 : monnier 416 (* internal-signals.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     * This is the internal view of the Signals structure.
6 :     *)
7 :    
8 :     local
9 :     structure String = StringImp
10 :     structure Int = IntImp
11 :     in
12 :     structure InternalSignals : sig
13 :    
14 :     include SIGNALS
15 :    
16 :     val initSigTbl : 'a -> unit
17 :     val clearSigTbl : 'a -> unit
18 :     val resetSigTbl : 'a -> unit
19 :    
20 :     end = struct
21 :    
22 :     structure CI = CInterface
23 :    
24 :     fun signalFn x = CI.c_function "SMLNJ-Signals" x
25 :    
26 :     datatype signal = SIG of CI.system_const
27 :    
28 :     datatype sig_action
29 :     = IGNORE
30 :     | DEFAULT
31 : monnier 429 | HANDLER of (signal * int * unit PrimTypes.cont) -> unit PrimTypes.cont
32 : monnier 416
33 :     fun sigToConst (SIG sc) = sc
34 :     fun constToSig sc = SIG sc
35 :    
36 :     (* the list of supported signals, its length, and the maximum signal code.
37 :     * We assume that the signal codes do not change, but that the number of
38 :     * supported signals might vary between versions of the run-time system.
39 :     *)
40 :     type sig_info = {act : sig_action, mask : int, signal : signal}
41 :     local
42 :     val listSignals' : unit -> CI.system_const list = signalFn "listSignals"
43 :     fun findMax sigs =
44 :     List.foldl
45 :     (fn (SIG(sigId, _), id) => if (id < sigId) then sigId else id)
46 :     ~1 sigs
47 :     in
48 :     val sigList : signal list ref = ref []
49 :     val numSigs = ref 0
50 :     val maxSig = ref ~1
51 :     val sigTbl : sig_info option Array.array ref =
52 :     ref(Array.fromList[])
53 :     (** DEBUG **)
54 :     val debug : string -> unit = CInterface.c_function "SMLNJ-RunT" "debug"
55 :     fun getInfo sigId = (case (Array.sub(!sigTbl, sigId))
56 :     of NONE => (
57 :     debug(String.concat[
58 :     "\n*** Internal error: undefined sigTbl entry for signal ",
59 :     Int.toString sigId, " ***\n"
60 :     ]);
61 :     raise Option.Option)
62 :     | (SOME info) => info
63 :     (* end case *))
64 :     (****
65 :     fun getInfo sigId = (case (Array.sub(!sigTbl, sigId))
66 :     of NONE => raise Option.Option
67 :     | (SOME info) => info
68 :     (* end case *))
69 :     ****)
70 :     fun setInfo (sigId, info) = Array.update(!sigTbl, sigId, SOME info)
71 :     fun resetList () = (
72 :     sigList := List.map constToSig (listSignals' ());
73 :     numSigs := List.length(! sigList);
74 :     maxSig := findMax(!sigList);
75 :     sigTbl := Array.array(!maxSig + 1, NONE))
76 :     end
77 :    
78 :     (* list the signals (and their names) supported by this version *)
79 :     fun listSignals () = (! sigList)
80 :    
81 :     (* return the name of a signal *)
82 :     fun toString (SIG(_, name)) = name
83 :    
84 :     (* return the signal with the corresponding name; returns NONE, if
85 :     * no such signal exists.
86 :     *)
87 :     fun fromString name = (
88 :     case CI.findSysConst (name, List.map sigToConst (!sigList))
89 :     of NONE => NONE
90 :     | (SOME sc) => SOME(SIG sc)
91 :     (* end case *))
92 :    
93 :     (* these run-time functions deal with the state of a signal in the system. *)
94 :     val getSigState : CI.system_const -> int = signalFn "getSigState"
95 :     val setSigState : (CI.system_const * int) -> unit = signalFn "setSigState"
96 :     (* The states are defined as: *)
97 :     val ignoreSigState = 0
98 :     val defaultSigState = 1
99 :     val enabledSigState = 2
100 :    
101 :     (* clear the signal table of handlers *)
102 :     fun clearSigTbl _ = Array.modify (fn _ => NONE) (!sigTbl)
103 :    
104 :     (* initialize the signal table to the inherited process environment *)
105 :     fun initSigTbl _ = let
106 :     fun initSig (s as (SIG sigId)) = let
107 :     val state = getSigState sigId
108 :     fun setState st = setInfo (#1 sigId, {act=st, mask=0, signal=s})
109 :     in
110 :     if (state = ignoreSigState) then setState IGNORE
111 :     else if (state = defaultSigState) then setState DEFAULT
112 :     else (* state = enabledSigState *)
113 :     raise Fail "unexpected signal handler"
114 :     end
115 :     in
116 :     resetList ();
117 :     List.app initSig (! sigList)
118 :     end
119 :    
120 :     (* reset the signal environment to agree with the signal table *)
121 :     fun resetSigTbl _ = let
122 :     val oldSigTbl = !sigTbl
123 :     val oldList = !sigList
124 :     fun copy (SIG sigId) = (case (Array.sub(oldSigTbl, #1 sigId))
125 :     of NONE => ()
126 :     | (SOME info) => (
127 :     setInfo (#1 sigId, info);
128 :     case (#act info)
129 :     of IGNORE => setSigState(sigId, ignoreSigState)
130 :     | DEFAULT => setSigState(sigId, defaultSigState)
131 :     | (HANDLER _) => setSigState(sigId, enabledSigState)
132 :     (* end case *))
133 :     (* end case *))
134 :     (** NOTE: we should probably notify the user that old signal handlers
135 :     ** are being lost, but there is no good way to do this right now.
136 :     **)
137 :     handle _ => ()
138 :     in
139 :     resetList ();
140 :     List.app copy oldList
141 :     end
142 :    
143 :     (* signal masking. *)
144 :    
145 :     datatype sigmask
146 :     = MASKALL
147 :     | MASK of signal list
148 :    
149 :     (* increment the masking level of the given signal by one, and return true.
150 :     *)
151 :     fun incMask (SIG(sigId, _)) = let
152 :     val {act, mask, signal} = getInfo sigId
153 :     in
154 :     setInfo(sigId, {act=act, mask=mask+1, signal=signal});
155 :     true
156 :     end
157 :     (* decrement the masking level of the given signal by one; return true,
158 :     * if the signal is still masked.
159 :     *)
160 :     fun decMask (SIG(sigId, _)) = let
161 :     val {act, mask, signal} = getInfo sigId
162 :     in
163 :     (mask <> 0) andalso (
164 :     setInfo(sigId, {act=act, mask=mask-1, signal=signal});
165 :     (mask <> 1))
166 :     end
167 :    
168 :     local
169 :     (* Run-time system API:
170 :     * NONE -- empty mask
171 :     * SOME[] -- mask all signals
172 :     * SOME l -- mask the signals in l
173 :     *)
174 :     val setSigMask : CI.system_const list option -> unit = signalFn "setSigMask"
175 :     val getSigMask : unit -> CI.system_const list option = signalFn "getSigMask"
176 :     fun applyMask maskFn mask = let
177 :     (* a simple insertion sort to eliminate duplicates *)
178 :     fun insert (s as SIG(id, _), []) = [s]
179 :     | insert (s as SIG(id, _), (s' as SIG(id', _))::r) =
180 :     if (id < id')
181 :     then s :: s' :: r
182 :     else if (id = id')
183 :     then s' :: r
184 :     else s' :: insert(s, r)
185 :     val sort = List.foldl insert []
186 :     (* apply the masking operations, return a list of signals that must
187 :     * be masked/unmasked at the OS level.
188 :     *)
189 :     fun f ([], l, n) = (l, n)
190 :     | f (s::r, l, n) =
191 :     if (maskFn s)
192 :     then f (r, (sigToConst s)::l, n+1)
193 :     else f (r, l, n)
194 :     val (l', numMasked) = (case mask
195 :     of MASKALL => f (!sigList, [], 0)
196 :     | (MASK l) => f (sort l, [], 0)
197 :     (* end case *))
198 :     in
199 :     if (numMasked = 0) then NONE
200 :     else if (numMasked = !numSigs) then SOME[]
201 :     else SOME l'
202 :     end
203 :     in
204 :     fun maskSignals mask = (case (applyMask incMask mask)
205 :     of NONE => ()
206 :     | m => setSigMask m
207 :     (* end case *))
208 :     fun unmaskSignals mask = (case (applyMask decMask mask)
209 :     of SOME[] => ()
210 :     | m=> setSigMask m
211 :     (* end case *))
212 :     fun masked () = (case getSigMask()
213 :     of NONE => MASK[]
214 :     | SOME[] => MASKALL
215 :     | SOME l => MASK(List.map constToSig l)
216 :     (* end case *))
217 :     end (* local *)
218 :    
219 :     (* set the handler for a signal, returning the previous action. *)
220 :     fun setHandler (s as (SIG sigId), act) = let
221 :     val _ = maskSignals MASKALL
222 :     val {act=oldAct, mask, ...} = getInfo(#1 sigId)
223 :     in
224 :     case (act, oldAct)
225 :     of (IGNORE, IGNORE) => ()
226 :     | (DEFAULT, DEFAULT) => ()
227 :     | (HANDLER _, HANDLER _) =>
228 :     setInfo(#1 sigId, {act=act, mask=mask, signal=s})
229 :     | (IGNORE, _) => (
230 :     setInfo(#1 sigId, {act=act, mask=mask, signal=s});
231 :     setSigState(sigId, ignoreSigState))
232 :     | (DEFAULT, _) => (
233 :     setInfo(#1 sigId, {act=act, mask=mask, signal=s});
234 :     setSigState(sigId, defaultSigState))
235 :     | (HANDLER _, _) => (
236 :     setInfo(#1 sigId, {act=act, mask=mask, signal=s});
237 :     setSigState(sigId, enabledSigState))
238 :     (* end case *);
239 :     unmaskSignals MASKALL;
240 :     oldAct
241 :     end
242 :    
243 :     (* if a signal is not being ignored, then set the handler. This
244 :     * returns the previous handler (if IGNORE, then the current handler
245 :     * is still IGNORE).
246 :     *)
247 :     fun overrideHandler (s as (SIG sigId), act) = let
248 :     val _ = maskSignals MASKALL
249 :     val {act=oldAct, mask, ...} = getInfo(#1 sigId)
250 :     in
251 :     case (oldAct, act)
252 :     of (IGNORE, _) => ()
253 :     | (DEFAULT, DEFAULT) => ()
254 :     | (HANDLER _, HANDLER _) =>
255 :     setInfo(#1 sigId, {act=act, mask=mask, signal=s})
256 :     | (_, IGNORE) => (
257 :     setInfo(#1 sigId, {act=act, mask=mask, signal=s});
258 :     setSigState(sigId, ignoreSigState))
259 :     | (_, DEFAULT) => (
260 :     setInfo(#1 sigId, {act=act, mask=mask, signal=s});
261 :     setSigState(sigId, defaultSigState))
262 :     | (_, HANDLER _) => (
263 :     setInfo(#1 sigId, {act=act, mask=mask, signal=s});
264 :     setSigState(sigId, enabledSigState))
265 :     (* end case *);
266 :     unmaskSignals MASKALL;
267 :     oldAct
268 :     end
269 :    
270 :     (* get the current action for the given signal *)
271 :     fun inqHandler (SIG(sigId, _)) = #act(getInfo sigId)
272 :    
273 :     (* sleep until the next signal; if called when signals are masked,
274 :     * then signals will still be masked when pause returns.
275 :     *)
276 :     val pause : unit -> unit = signalFn "pause"
277 :    
278 :     (* Here is the ML handler that gets invoked by the run-time system.
279 :     * It is responsible for dispatching the appropriate ML handler.
280 :     *)
281 : blume 842 fun sigHandler (code, count, resume_k) =
282 :     (case (Array.sub(!sigTbl, code))
283 :     of (SOME{act=HANDLER handler, mask=0, signal}) =>
284 :     handler(signal, count, resume_k)
285 : monnier 416 (*DEBUG
286 :     | _ => raise Fail "inconsistent internal signal state"
287 :     DEBUG*)
288 : blume 842 | info => let
289 :     val act = (case info
290 :     of NONE => "NONE"
291 :     | SOME{act=IGNORE, ...} => "IGNORE"
292 :     | SOME{act=DEFAULT, ...} => "DEFAULT"
293 :     | SOME{act=HANDLER _, mask, ... } =>
294 :     concat ["HANDLER(mask=",Int.toString mask,
295 :     "<>0)"]
296 :     (*end case *))
297 :     val msg = concat["inconsistent state ", act,
298 :     " for signal ", Int.toString code]
299 :     in raise Fail msg
300 :     end
301 :     (* end case *))
302 : monnier 416
303 :     (* Install the root handler *)
304 :     val _ = (Assembly.sighandler := sigHandler)
305 :    
306 :     (* initialize the signal list and table *)
307 :     val _ = initSigTbl()
308 :    
309 :     (* these signals should be supported even on non-UNIX platforms. *)
310 :     val sigINT = Option.valOf(fromString "INT")
311 :     val sigALRM = Option.valOf(fromString "ALRM")
312 :     val sigTERM = Option.valOf(fromString "TERM")
313 :     val sigGC = Option.valOf(fromString "GC")
314 :    
315 : dbm 589 end (* Signals *)
316 :     end (* local *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0