|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1991-2017, Florida State University --
|
|
131
|
10 -- Copyright (C) 1995-2018, AdaCore --
|
|
111
|
11 -- --
|
|
|
12 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
13 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
14 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
17 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
|
18 -- --
|
|
|
19 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
20 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
21 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
22 -- --
|
|
|
23 -- You should have received a copy of the GNU General Public License and --
|
|
|
24 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
25 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
26 -- <http://www.gnu.org/licenses/>. --
|
|
|
27 -- --
|
|
|
28 -- GNARL was developed by the GNARL team at Florida State University. --
|
|
|
29 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
|
|
|
30 -- --
|
|
|
31 ------------------------------------------------------------------------------
|
|
|
32
|
|
|
33 -- This is a POSIX-like version of this package
|
|
|
34
|
|
|
35 -- Note: this file can only be used for POSIX compliant systems
|
|
|
36
|
|
|
37 with Interfaces.C;
|
|
|
38
|
|
|
39 with System.OS_Interface;
|
|
|
40 with System.Storage_Elements;
|
|
|
41
|
|
|
42 package body System.Interrupt_Management.Operations is
|
|
|
43
|
|
|
44 use Interfaces.C;
|
|
|
45 use System.OS_Interface;
|
|
|
46
|
|
|
47 ---------------------
|
|
|
48 -- Local Variables --
|
|
|
49 ---------------------
|
|
|
50
|
|
|
51 Initial_Action : array (Signal) of aliased struct_sigaction;
|
|
|
52
|
|
|
53 Default_Action : aliased struct_sigaction;
|
|
|
54 pragma Warnings (Off, Default_Action);
|
|
|
55
|
|
|
56 Ignore_Action : aliased struct_sigaction;
|
|
|
57
|
|
|
58 ----------------------------
|
|
|
59 -- Thread_Block_Interrupt --
|
|
|
60 ----------------------------
|
|
|
61
|
|
|
62 procedure Thread_Block_Interrupt
|
|
|
63 (Interrupt : Interrupt_ID)
|
|
|
64 is
|
|
|
65 Result : Interfaces.C.int;
|
|
|
66 Mask : aliased sigset_t;
|
|
|
67 begin
|
|
|
68 Result := sigemptyset (Mask'Access);
|
|
|
69 pragma Assert (Result = 0);
|
|
|
70 Result := sigaddset (Mask'Access, Signal (Interrupt));
|
|
|
71 pragma Assert (Result = 0);
|
|
|
72 Result := pthread_sigmask (SIG_BLOCK, Mask'Access, null);
|
|
|
73 pragma Assert (Result = 0);
|
|
|
74 end Thread_Block_Interrupt;
|
|
|
75
|
|
|
76 ------------------------------
|
|
|
77 -- Thread_Unblock_Interrupt --
|
|
|
78 ------------------------------
|
|
|
79
|
|
|
80 procedure Thread_Unblock_Interrupt
|
|
|
81 (Interrupt : Interrupt_ID)
|
|
|
82 is
|
|
|
83 Mask : aliased sigset_t;
|
|
|
84 Result : Interfaces.C.int;
|
|
|
85 begin
|
|
|
86 Result := sigemptyset (Mask'Access);
|
|
|
87 pragma Assert (Result = 0);
|
|
|
88 Result := sigaddset (Mask'Access, Signal (Interrupt));
|
|
|
89 pragma Assert (Result = 0);
|
|
|
90 Result := pthread_sigmask (SIG_UNBLOCK, Mask'Access, null);
|
|
|
91 pragma Assert (Result = 0);
|
|
|
92 end Thread_Unblock_Interrupt;
|
|
|
93
|
|
|
94 ------------------------
|
|
|
95 -- Set_Interrupt_Mask --
|
|
|
96 ------------------------
|
|
|
97
|
|
|
98 procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
|
|
|
99 Result : Interfaces.C.int;
|
|
|
100 begin
|
|
|
101 Result := pthread_sigmask (SIG_SETMASK, Mask, null);
|
|
|
102 pragma Assert (Result = 0);
|
|
|
103 end Set_Interrupt_Mask;
|
|
|
104
|
|
|
105 procedure Set_Interrupt_Mask
|
|
|
106 (Mask : access Interrupt_Mask;
|
|
|
107 OMask : access Interrupt_Mask)
|
|
|
108 is
|
|
|
109 Result : Interfaces.C.int;
|
|
|
110 begin
|
|
|
111 Result := pthread_sigmask (SIG_SETMASK, Mask, OMask);
|
|
|
112 pragma Assert (Result = 0);
|
|
|
113 end Set_Interrupt_Mask;
|
|
|
114
|
|
|
115 ------------------------
|
|
|
116 -- Get_Interrupt_Mask --
|
|
|
117 ------------------------
|
|
|
118
|
|
|
119 procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
|
|
|
120 Result : Interfaces.C.int;
|
|
|
121 begin
|
|
|
122 Result := pthread_sigmask (SIG_SETMASK, null, Mask);
|
|
|
123 pragma Assert (Result = 0);
|
|
|
124 end Get_Interrupt_Mask;
|
|
|
125
|
|
|
126 --------------------
|
|
|
127 -- Interrupt_Wait --
|
|
|
128 --------------------
|
|
|
129
|
|
|
130 function Interrupt_Wait
|
|
|
131 (Mask : access Interrupt_Mask) return Interrupt_ID
|
|
|
132 is
|
|
|
133 Result : Interfaces.C.int;
|
|
|
134 Sig : aliased Signal;
|
|
|
135
|
|
|
136 begin
|
|
|
137 Result := sigwait (Mask, Sig'Access);
|
|
|
138
|
|
|
139 if Result /= 0 then
|
|
|
140 return 0;
|
|
|
141 end if;
|
|
|
142
|
|
|
143 return Interrupt_ID (Sig);
|
|
|
144 end Interrupt_Wait;
|
|
|
145
|
|
|
146 ----------------------------
|
|
|
147 -- Install_Default_Action --
|
|
|
148 ----------------------------
|
|
|
149
|
|
|
150 procedure Install_Default_Action (Interrupt : Interrupt_ID) is
|
|
|
151 Result : Interfaces.C.int;
|
|
|
152 begin
|
|
|
153 Result := sigaction
|
|
|
154 (Signal (Interrupt),
|
|
|
155 Initial_Action (Signal (Interrupt))'Access, null);
|
|
|
156 pragma Assert (Result = 0);
|
|
|
157 end Install_Default_Action;
|
|
|
158
|
|
|
159 ---------------------------
|
|
|
160 -- Install_Ignore_Action --
|
|
|
161 ---------------------------
|
|
|
162
|
|
|
163 procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
|
|
|
164 Result : Interfaces.C.int;
|
|
|
165 begin
|
|
|
166 Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
|
|
|
167 pragma Assert (Result = 0);
|
|
|
168 end Install_Ignore_Action;
|
|
|
169
|
|
|
170 -------------------------
|
|
|
171 -- Fill_Interrupt_Mask --
|
|
|
172 -------------------------
|
|
|
173
|
|
|
174 procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
|
|
|
175 Result : Interfaces.C.int;
|
|
|
176 begin
|
|
|
177 Result := sigfillset (Mask);
|
|
|
178 pragma Assert (Result = 0);
|
|
|
179 end Fill_Interrupt_Mask;
|
|
|
180
|
|
|
181 --------------------------
|
|
|
182 -- Empty_Interrupt_Mask --
|
|
|
183 --------------------------
|
|
|
184
|
|
|
185 procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
|
|
|
186 Result : Interfaces.C.int;
|
|
|
187 begin
|
|
|
188 Result := sigemptyset (Mask);
|
|
|
189 pragma Assert (Result = 0);
|
|
|
190 end Empty_Interrupt_Mask;
|
|
|
191
|
|
|
192 ---------------------------
|
|
|
193 -- Add_To_Interrupt_Mask --
|
|
|
194 ---------------------------
|
|
|
195
|
|
|
196 procedure Add_To_Interrupt_Mask
|
|
|
197 (Mask : access Interrupt_Mask;
|
|
|
198 Interrupt : Interrupt_ID)
|
|
|
199 is
|
|
|
200 Result : Interfaces.C.int;
|
|
|
201 begin
|
|
|
202 Result := sigaddset (Mask, Signal (Interrupt));
|
|
|
203 pragma Assert (Result = 0);
|
|
|
204 end Add_To_Interrupt_Mask;
|
|
|
205
|
|
|
206 --------------------------------
|
|
|
207 -- Delete_From_Interrupt_Mask --
|
|
|
208 --------------------------------
|
|
|
209
|
|
|
210 procedure Delete_From_Interrupt_Mask
|
|
|
211 (Mask : access Interrupt_Mask;
|
|
|
212 Interrupt : Interrupt_ID)
|
|
|
213 is
|
|
|
214 Result : Interfaces.C.int;
|
|
|
215 begin
|
|
|
216 Result := sigdelset (Mask, Signal (Interrupt));
|
|
|
217 pragma Assert (Result = 0);
|
|
|
218 end Delete_From_Interrupt_Mask;
|
|
|
219
|
|
|
220 ---------------
|
|
|
221 -- Is_Member --
|
|
|
222 ---------------
|
|
|
223
|
|
|
224 function Is_Member
|
|
|
225 (Mask : access Interrupt_Mask;
|
|
|
226 Interrupt : Interrupt_ID) return Boolean
|
|
|
227 is
|
|
|
228 Result : Interfaces.C.int;
|
|
|
229 begin
|
|
|
230 Result := sigismember (Mask, Signal (Interrupt));
|
|
|
231 pragma Assert (Result = 0 or else Result = 1);
|
|
|
232 return Result = 1;
|
|
|
233 end Is_Member;
|
|
|
234
|
|
|
235 -------------------------
|
|
|
236 -- Copy_Interrupt_Mask --
|
|
|
237 -------------------------
|
|
|
238
|
|
|
239 procedure Copy_Interrupt_Mask
|
|
|
240 (X : out Interrupt_Mask;
|
|
|
241 Y : Interrupt_Mask) is
|
|
|
242 begin
|
|
|
243 X := Y;
|
|
|
244 end Copy_Interrupt_Mask;
|
|
|
245
|
|
|
246 ----------------------------
|
|
|
247 -- Interrupt_Self_Process --
|
|
|
248 ----------------------------
|
|
|
249
|
|
|
250 procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
|
|
|
251 Result : Interfaces.C.int;
|
|
|
252 begin
|
|
|
253 Result := kill (getpid, Signal (Interrupt));
|
|
|
254 pragma Assert (Result = 0);
|
|
|
255 end Interrupt_Self_Process;
|
|
|
256
|
|
|
257 --------------------------
|
|
|
258 -- Setup_Interrupt_Mask --
|
|
|
259 --------------------------
|
|
|
260
|
|
|
261 procedure Setup_Interrupt_Mask is
|
|
|
262 begin
|
|
|
263 -- Mask task for all signals. The original mask of the Environment task
|
|
|
264 -- will be recovered by Interrupt_Manager task during the elaboration
|
|
|
265 -- of s-interr.adb.
|
|
|
266
|
|
|
267 Set_Interrupt_Mask (All_Tasks_Mask'Access);
|
|
|
268 end Setup_Interrupt_Mask;
|
|
|
269
|
|
|
270 begin
|
|
|
271 declare
|
|
|
272 mask : aliased sigset_t;
|
|
|
273 allmask : aliased sigset_t;
|
|
|
274 Result : Interfaces.C.int;
|
|
|
275
|
|
|
276 begin
|
|
|
277 Interrupt_Management.Initialize;
|
|
|
278
|
|
|
279 for Sig in 1 .. Signal'Last loop
|
|
|
280 Result := sigaction
|
|
|
281 (Sig, null, Initial_Action (Sig)'Access);
|
|
|
282
|
|
|
283 -- ??? [assert 1]
|
|
|
284 -- we can't check Result here since sigaction will fail on
|
|
|
285 -- SIGKILL, SIGSTOP, and possibly other signals
|
|
|
286 -- pragma Assert (Result = 0);
|
|
|
287
|
|
|
288 end loop;
|
|
|
289
|
|
|
290 -- Setup the masks to be exported
|
|
|
291
|
|
|
292 Result := sigemptyset (mask'Access);
|
|
|
293 pragma Assert (Result = 0);
|
|
|
294
|
|
|
295 Result := sigfillset (allmask'Access);
|
|
|
296 pragma Assert (Result = 0);
|
|
|
297
|
|
|
298 Default_Action.sa_flags := 0;
|
|
|
299 Default_Action.sa_mask := mask;
|
|
|
300 Default_Action.sa_handler :=
|
|
|
301 Storage_Elements.To_Address
|
|
|
302 (Storage_Elements.Integer_Address (SIG_DFL));
|
|
|
303
|
|
|
304 Ignore_Action.sa_flags := 0;
|
|
|
305 Ignore_Action.sa_mask := mask;
|
|
|
306 Ignore_Action.sa_handler :=
|
|
|
307 Storage_Elements.To_Address
|
|
|
308 (Storage_Elements.Integer_Address (SIG_IGN));
|
|
|
309
|
|
|
310 for J in Interrupt_ID loop
|
|
|
311 if Keep_Unmasked (J) then
|
|
|
312 Result := sigaddset (mask'Access, Signal (J));
|
|
|
313 pragma Assert (Result = 0);
|
|
|
314 Result := sigdelset (allmask'Access, Signal (J));
|
|
|
315 pragma Assert (Result = 0);
|
|
|
316 end if;
|
|
|
317 end loop;
|
|
|
318
|
|
|
319 -- The Keep_Unmasked signals should be unmasked for Environment task
|
|
|
320
|
|
|
321 Result := pthread_sigmask (SIG_UNBLOCK, mask'Access, null);
|
|
|
322 pragma Assert (Result = 0);
|
|
|
323
|
|
|
324 -- Get the signal mask of the Environment Task
|
|
|
325
|
|
|
326 Result := pthread_sigmask (SIG_SETMASK, null, mask'Access);
|
|
|
327 pragma Assert (Result = 0);
|
|
|
328
|
|
|
329 -- Setup the constants exported
|
|
|
330
|
|
|
331 Environment_Mask := Interrupt_Mask (mask);
|
|
|
332
|
|
|
333 All_Tasks_Mask := Interrupt_Mask (allmask);
|
|
|
334 end;
|
|
|
335
|
|
|
336 end System.Interrupt_Management.Operations;
|
