Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnarl/s-inmaop__posix.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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 --
10 -- Copyright (C) 1995-2017, AdaCore --
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;