1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
9 -- Copyright (C) 1991-1994, Florida State University --
10 -- Copyright (C) 1995-2008, AdaCore --
12 -- GNARL 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 2, or (at your option) any later ver- --
15 -- sion. GNARL 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. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. --
31 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
33 ------------------------------------------------------------------------------
35 -- This is a POSIX-like version of this package
37 -- Note: this file can only be used for POSIX compliant systems
41 with System
.OS_Interface
;
42 with System
.Storage_Elements
;
44 package body System
.Interrupt_Management
.Operations
is
47 use System
.OS_Interface
;
53 Initial_Action
: array (Signal
) of aliased struct_sigaction
;
55 Default_Action
: aliased struct_sigaction
;
56 pragma Warnings
(Off
, Default_Action
);
58 Ignore_Action
: aliased struct_sigaction
;
60 ----------------------------
61 -- Thread_Block_Interrupt --
62 ----------------------------
64 procedure Thread_Block_Interrupt
65 (Interrupt
: Interrupt_ID
)
67 Result
: Interfaces
.C
.int
;
68 Mask
: aliased sigset_t
;
70 Result
:= sigemptyset
(Mask
'Access);
71 pragma Assert
(Result
= 0);
72 Result
:= sigaddset
(Mask
'Access, Signal
(Interrupt
));
73 pragma Assert
(Result
= 0);
74 Result
:= pthread_sigmask
(SIG_BLOCK
, Mask
'Access, null);
75 pragma Assert
(Result
= 0);
76 end Thread_Block_Interrupt
;
78 ------------------------------
79 -- Thread_Unblock_Interrupt --
80 ------------------------------
82 procedure Thread_Unblock_Interrupt
83 (Interrupt
: Interrupt_ID
)
85 Mask
: aliased sigset_t
;
86 Result
: Interfaces
.C
.int
;
88 Result
:= sigemptyset
(Mask
'Access);
89 pragma Assert
(Result
= 0);
90 Result
:= sigaddset
(Mask
'Access, Signal
(Interrupt
));
91 pragma Assert
(Result
= 0);
92 Result
:= pthread_sigmask
(SIG_UNBLOCK
, Mask
'Access, null);
93 pragma Assert
(Result
= 0);
94 end Thread_Unblock_Interrupt
;
96 ------------------------
97 -- Set_Interrupt_Mask --
98 ------------------------
100 procedure Set_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
101 Result
: Interfaces
.C
.int
;
103 Result
:= pthread_sigmask
(SIG_SETMASK
, Mask
, null);
104 pragma Assert
(Result
= 0);
105 end Set_Interrupt_Mask
;
107 procedure Set_Interrupt_Mask
108 (Mask
: access Interrupt_Mask
;
109 OMask
: access Interrupt_Mask
)
111 Result
: Interfaces
.C
.int
;
113 Result
:= pthread_sigmask
(SIG_SETMASK
, Mask
, OMask
);
114 pragma Assert
(Result
= 0);
115 end Set_Interrupt_Mask
;
117 ------------------------
118 -- Get_Interrupt_Mask --
119 ------------------------
121 procedure Get_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
122 Result
: Interfaces
.C
.int
;
124 Result
:= pthread_sigmask
(SIG_SETMASK
, null, Mask
);
125 pragma Assert
(Result
= 0);
126 end Get_Interrupt_Mask
;
132 function Interrupt_Wait
133 (Mask
: access Interrupt_Mask
) return Interrupt_ID
135 Result
: Interfaces
.C
.int
;
136 Sig
: aliased Signal
;
139 Result
:= sigwait
(Mask
, Sig
'Access);
145 return Interrupt_ID
(Sig
);
148 ----------------------------
149 -- Install_Default_Action --
150 ----------------------------
152 procedure Install_Default_Action
(Interrupt
: Interrupt_ID
) is
153 Result
: Interfaces
.C
.int
;
157 Initial_Action
(Signal
(Interrupt
))'Access, null);
158 pragma Assert
(Result
= 0);
159 end Install_Default_Action
;
161 ---------------------------
162 -- Install_Ignore_Action --
163 ---------------------------
165 procedure Install_Ignore_Action
(Interrupt
: Interrupt_ID
) is
166 Result
: Interfaces
.C
.int
;
168 Result
:= sigaction
(Signal
(Interrupt
), Ignore_Action
'Access, null);
169 pragma Assert
(Result
= 0);
170 end Install_Ignore_Action
;
172 -------------------------
173 -- Fill_Interrupt_Mask --
174 -------------------------
176 procedure Fill_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
177 Result
: Interfaces
.C
.int
;
179 Result
:= sigfillset
(Mask
);
180 pragma Assert
(Result
= 0);
181 end Fill_Interrupt_Mask
;
183 --------------------------
184 -- Empty_Interrupt_Mask --
185 --------------------------
187 procedure Empty_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
188 Result
: Interfaces
.C
.int
;
190 Result
:= sigemptyset
(Mask
);
191 pragma Assert
(Result
= 0);
192 end Empty_Interrupt_Mask
;
194 ---------------------------
195 -- Add_To_Interrupt_Mask --
196 ---------------------------
198 procedure Add_To_Interrupt_Mask
199 (Mask
: access Interrupt_Mask
;
200 Interrupt
: Interrupt_ID
)
202 Result
: Interfaces
.C
.int
;
204 Result
:= sigaddset
(Mask
, Signal
(Interrupt
));
205 pragma Assert
(Result
= 0);
206 end Add_To_Interrupt_Mask
;
208 --------------------------------
209 -- Delete_From_Interrupt_Mask --
210 --------------------------------
212 procedure Delete_From_Interrupt_Mask
213 (Mask
: access Interrupt_Mask
;
214 Interrupt
: Interrupt_ID
)
216 Result
: Interfaces
.C
.int
;
218 Result
:= sigdelset
(Mask
, Signal
(Interrupt
));
219 pragma Assert
(Result
= 0);
220 end Delete_From_Interrupt_Mask
;
227 (Mask
: access Interrupt_Mask
;
228 Interrupt
: Interrupt_ID
) return Boolean
230 Result
: Interfaces
.C
.int
;
232 Result
:= sigismember
(Mask
, Signal
(Interrupt
));
233 pragma Assert
(Result
= 0 or else Result
= 1);
237 -------------------------
238 -- Copy_Interrupt_Mask --
239 -------------------------
241 procedure Copy_Interrupt_Mask
242 (X
: out Interrupt_Mask
;
243 Y
: Interrupt_Mask
) is
246 end Copy_Interrupt_Mask
;
248 ----------------------------
249 -- Interrupt_Self_Process --
250 ----------------------------
252 procedure Interrupt_Self_Process
(Interrupt
: Interrupt_ID
) is
253 Result
: Interfaces
.C
.int
;
255 Result
:= kill
(getpid
, Signal
(Interrupt
));
256 pragma Assert
(Result
= 0);
257 end Interrupt_Self_Process
;
259 --------------------------
260 -- Setup_Interrupt_Mask --
261 --------------------------
263 procedure Setup_Interrupt_Mask
is
265 -- Mask task for all signals. The original mask of the Environment task
266 -- will be recovered by Interrupt_Manager task during the elaboration
269 Set_Interrupt_Mask
(All_Tasks_Mask
'Access);
270 end Setup_Interrupt_Mask
;
274 mask
: aliased sigset_t
;
275 allmask
: aliased sigset_t
;
276 Result
: Interfaces
.C
.int
;
279 Interrupt_Management
.Initialize
;
281 for Sig
in 1 .. Signal
'Last loop
283 (Sig
, null, Initial_Action
(Sig
)'Access);
286 -- we can't check Result here since sigaction will fail on
287 -- SIGKILL, SIGSTOP, and possibly other signals
288 -- pragma Assert (Result = 0);
292 -- Setup the masks to be exported
294 Result
:= sigemptyset
(mask
'Access);
295 pragma Assert
(Result
= 0);
297 Result
:= sigfillset
(allmask
'Access);
298 pragma Assert
(Result
= 0);
300 Default_Action
.sa_flags
:= 0;
301 Default_Action
.sa_mask
:= mask
;
302 Default_Action
.sa_handler
:=
303 Storage_Elements
.To_Address
304 (Storage_Elements
.Integer_Address
(SIG_DFL
));
306 Ignore_Action
.sa_flags
:= 0;
307 Ignore_Action
.sa_mask
:= mask
;
308 Ignore_Action
.sa_handler
:=
309 Storage_Elements
.To_Address
310 (Storage_Elements
.Integer_Address
(SIG_IGN
));
312 for J
in Interrupt_ID
loop
313 if Keep_Unmasked
(J
) then
314 Result
:= sigaddset
(mask
'Access, Signal
(J
));
315 pragma Assert
(Result
= 0);
316 Result
:= sigdelset
(allmask
'Access, Signal
(J
));
317 pragma Assert
(Result
= 0);
321 -- The Keep_Unmasked signals should be unmasked for Environment task
323 Result
:= pthread_sigmask
(SIG_UNBLOCK
, mask
'Access, null);
324 pragma Assert
(Result
= 0);
326 -- Get the signal mask of the Environment Task
328 Result
:= pthread_sigmask
(SIG_SETMASK
, null, mask
'Access);
329 pragma Assert
(Result
= 0);
331 -- Setup the constants exported
333 Environment_Mask
:= Interrupt_Mask
(mask
);
335 All_Tasks_Mask
:= Interrupt_Mask
(allmask
);
338 end System
.Interrupt_Management
.Operations
;