1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . --
6 -- O P E R A T I O N S --
10 -- Copyright (C) 1991-1994, Florida State University --
11 -- Copyright (C) 1995-2005, AdaCore --
13 -- GNARL is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNARL; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
22 -- Boston, MA 02110-1301, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNARL was developed by the GNARL team at Florida State University. --
32 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
34 ------------------------------------------------------------------------------
36 -- This is a POSIX-like version of this package.
37 -- Note: this file can only be used for POSIX compliant systems.
44 with System
.OS_Interface
;
45 -- used for various type, constant, and operations
47 with System
.Storage_Elements
;
48 -- used for To_Address
51 with Unchecked_Conversion
;
53 package body System
.Interrupt_Management
.Operations
is
56 use System
.OS_Interface
;
58 type Interrupt_Mask_Ptr
is access all Interrupt_Mask
;
61 Unchecked_Conversion
(Interrupt_Mask_Ptr
, sigset_t_ptr
);
67 Initial_Action
: array (Signal
) of aliased struct_sigaction
;
69 Default_Action
: aliased struct_sigaction
;
71 Ignore_Action
: aliased struct_sigaction
;
73 ----------------------------
74 -- Thread_Block_Interrupt --
75 ----------------------------
77 procedure Thread_Block_Interrupt
78 (Interrupt
: Interrupt_ID
)
80 Result
: Interfaces
.C
.int
;
81 Mask
: aliased sigset_t
;
83 Result
:= sigemptyset
(Mask
'Access);
84 pragma Assert
(Result
= 0);
85 Result
:= sigaddset
(Mask
'Access, Signal
(Interrupt
));
86 pragma Assert
(Result
= 0);
87 Result
:= pthread_sigmask
(SIG_BLOCK
, Mask
'Unchecked_Access, null);
88 pragma Assert
(Result
= 0);
89 end Thread_Block_Interrupt
;
91 ------------------------------
92 -- Thread_Unblock_Interrupt --
93 ------------------------------
95 procedure Thread_Unblock_Interrupt
96 (Interrupt
: Interrupt_ID
)
98 Mask
: aliased sigset_t
;
99 Result
: Interfaces
.C
.int
;
101 Result
:= sigemptyset
(Mask
'Access);
102 pragma Assert
(Result
= 0);
103 Result
:= sigaddset
(Mask
'Access, Signal
(Interrupt
));
104 pragma Assert
(Result
= 0);
105 Result
:= pthread_sigmask
(SIG_UNBLOCK
, Mask
'Unchecked_Access, null);
106 pragma Assert
(Result
= 0);
107 end Thread_Unblock_Interrupt
;
109 ------------------------
110 -- Set_Interrupt_Mask --
111 ------------------------
113 procedure Set_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
114 Result
: Interfaces
.C
.int
;
116 Result
:= pthread_sigmask
117 (SIG_SETMASK
, +Interrupt_Mask_Ptr
(Mask
), null);
118 pragma Assert
(Result
= 0);
119 end Set_Interrupt_Mask
;
121 procedure Set_Interrupt_Mask
122 (Mask
: access Interrupt_Mask
;
123 OMask
: access Interrupt_Mask
)
125 Result
: Interfaces
.C
.int
;
127 Result
:= pthread_sigmask
128 (SIG_SETMASK
, +Interrupt_Mask_Ptr
(Mask
), +Interrupt_Mask_Ptr
(OMask
));
129 pragma Assert
(Result
= 0);
130 end Set_Interrupt_Mask
;
132 ------------------------
133 -- Get_Interrupt_Mask --
134 ------------------------
136 procedure Get_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
137 Result
: Interfaces
.C
.int
;
139 Result
:= pthread_sigmask
140 (SIG_SETMASK
, null, +Interrupt_Mask_Ptr
(Mask
));
141 pragma Assert
(Result
= 0);
142 end Get_Interrupt_Mask
;
148 function Interrupt_Wait
149 (Mask
: access Interrupt_Mask
)
152 Result
: Interfaces
.C
.int
;
153 Sig
: aliased Signal
;
155 Result
:= sigwait
(Mask
, Sig
'Access);
161 return Interrupt_ID
(Sig
);
164 ----------------------------
165 -- Install_Default_Action --
166 ----------------------------
168 procedure Install_Default_Action
(Interrupt
: Interrupt_ID
) is
169 Result
: Interfaces
.C
.int
;
173 Initial_Action
(Signal
(Interrupt
))'Access, null);
174 pragma Assert
(Result
= 0);
175 end Install_Default_Action
;
177 ---------------------------
178 -- Install_Ignore_Action --
179 ---------------------------
181 procedure Install_Ignore_Action
(Interrupt
: Interrupt_ID
) is
182 Result
: Interfaces
.C
.int
;
184 Result
:= sigaction
(Signal
(Interrupt
), Ignore_Action
'Access, null);
185 pragma Assert
(Result
= 0);
186 end Install_Ignore_Action
;
188 -------------------------
189 -- Fill_Interrupt_Mask --
190 -------------------------
192 procedure Fill_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
193 Result
: Interfaces
.C
.int
;
195 Result
:= sigfillset
(Mask
);
196 pragma Assert
(Result
= 0);
197 end Fill_Interrupt_Mask
;
199 --------------------------
200 -- Empty_Interrupt_Mask --
201 --------------------------
203 procedure Empty_Interrupt_Mask
(Mask
: access Interrupt_Mask
) is
204 Result
: Interfaces
.C
.int
;
206 Result
:= sigemptyset
(Mask
);
207 pragma Assert
(Result
= 0);
208 end Empty_Interrupt_Mask
;
210 ---------------------------
211 -- Add_To_Interrupt_Mask --
212 ---------------------------
214 procedure Add_To_Interrupt_Mask
215 (Mask
: access Interrupt_Mask
;
216 Interrupt
: Interrupt_ID
)
218 Result
: Interfaces
.C
.int
;
220 Result
:= sigaddset
(Mask
, Signal
(Interrupt
));
221 pragma Assert
(Result
= 0);
222 end Add_To_Interrupt_Mask
;
224 --------------------------------
225 -- Delete_From_Interrupt_Mask --
226 --------------------------------
228 procedure Delete_From_Interrupt_Mask
229 (Mask
: access Interrupt_Mask
;
230 Interrupt
: Interrupt_ID
)
232 Result
: Interfaces
.C
.int
;
234 Result
:= sigdelset
(Mask
, Signal
(Interrupt
));
235 pragma Assert
(Result
= 0);
236 end Delete_From_Interrupt_Mask
;
243 (Mask
: access Interrupt_Mask
;
244 Interrupt
: Interrupt_ID
) return Boolean
246 Result
: Interfaces
.C
.int
;
248 Result
:= sigismember
(Mask
, Signal
(Interrupt
));
249 pragma Assert
(Result
= 0 or else Result
= 1);
253 -------------------------
254 -- Copy_Interrupt_Mask --
255 -------------------------
257 procedure Copy_Interrupt_Mask
258 (X
: out Interrupt_Mask
;
259 Y
: Interrupt_Mask
) is
262 end Copy_Interrupt_Mask
;
264 ----------------------------
265 -- Interrupt_Self_Process --
266 ----------------------------
268 procedure Interrupt_Self_Process
(Interrupt
: Interrupt_ID
) is
269 Result
: Interfaces
.C
.int
;
271 Result
:= kill
(getpid
, Signal
(Interrupt
));
272 pragma Assert
(Result
= 0);
273 end Interrupt_Self_Process
;
275 --------------------------
276 -- Setup_Interrupt_Mask --
277 --------------------------
279 procedure Setup_Interrupt_Mask
is
281 -- Mask task for all signals. The original mask of the Environment task
282 -- will be recovered by Interrupt_Manager task during the elaboration
285 Set_Interrupt_Mask
(All_Tasks_Mask
'Access);
286 end Setup_Interrupt_Mask
;
290 mask
: aliased sigset_t
;
291 allmask
: aliased sigset_t
;
292 Result
: Interfaces
.C
.int
;
295 Interrupt_Management
.Initialize
;
297 for Sig
in 1 .. Signal
'Last loop
299 (Sig
, null, Initial_Action
(Sig
)'Unchecked_Access);
302 -- we can't check Result here since sigaction will fail on
303 -- SIGKILL, SIGSTOP, and possibly other signals
304 -- pragma Assert (Result = 0);
308 -- Setup the masks to be exported.
310 Result
:= sigemptyset
(mask
'Access);
311 pragma Assert
(Result
= 0);
313 Result
:= sigfillset
(allmask
'Access);
314 pragma Assert
(Result
= 0);
316 Default_Action
.sa_flags
:= 0;
317 Default_Action
.sa_mask
:= mask
;
318 Default_Action
.sa_handler
:=
319 Storage_Elements
.To_Address
320 (Storage_Elements
.Integer_Address
(SIG_DFL
));
322 Ignore_Action
.sa_flags
:= 0;
323 Ignore_Action
.sa_mask
:= mask
;
324 Ignore_Action
.sa_handler
:=
325 Storage_Elements
.To_Address
326 (Storage_Elements
.Integer_Address
(SIG_IGN
));
328 for J
in Interrupt_ID
loop
330 -- We need to check whether J is in Keep_Unmasked because
331 -- the index type of the Keep_Unmasked array is not always
332 -- Interrupt_ID; it may be a subtype of Interrupt_ID.
334 if J
in Keep_Unmasked
'Range and then Keep_Unmasked
(J
) then
335 Result
:= sigaddset
(mask
'Access, Signal
(J
));
336 pragma Assert
(Result
= 0);
337 Result
:= sigdelset
(allmask
'Access, Signal
(J
));
338 pragma Assert
(Result
= 0);
342 -- The Keep_Unmasked signals should be unmasked for Environment task
344 Result
:= pthread_sigmask
(SIG_UNBLOCK
, mask
'Unchecked_Access, null);
345 pragma Assert
(Result
= 0);
347 -- Get the signal mask of the Environment Task
349 Result
:= pthread_sigmask
(SIG_SETMASK
, null, mask
'Unchecked_Access);
350 pragma Assert
(Result
= 0);
352 -- Setup the constants exported
354 Environment_Mask
:= Interrupt_Mask
(mask
);
356 All_Tasks_Mask
:= Interrupt_Mask
(allmask
);
359 end System
.Interrupt_Management
.Operations
;