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 --
9 -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This is the POSIX threads version of this package
36 -- Make a careful study of all signals available under the OS, to see which
37 -- need to be reserved, kept always unmasked, or kept always unmasked. Be on
38 -- the lookout for special signals that may be used by the thread library.
40 -- Since this is a multi target file, the signal <-> exception mapping
41 -- is simple minded. If you need a more precise and target specific
42 -- signal handling, create a new s-intman.adb that will fit your needs.
44 -- This file assumes that:
46 -- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows:
47 -- SIGPFE => Constraint_Error
48 -- SIGILL => Program_Error
49 -- SIGSEGV => Storage_Error
50 -- SIGBUS => Storage_Error
52 -- SIGINT exists and will be kept unmasked unless the pragma
53 -- Unreserve_All_Interrupts is specified anywhere in the application.
55 -- System.OS_Interface contains the following:
56 -- SIGADAABORT: the signal that will be used to abort tasks.
57 -- Unmasked: the OS specific set of signals that should be unmasked in
58 -- all the threads. SIGADAABORT is unmasked by
60 -- Reserved: the OS specific set of signals that are reserved.
63 -- used for int and other types
65 with System
.OS_Interface
;
66 -- used for various Constants, Signal and types
68 package body System
.Interrupt_Management
is
71 use System
.OS_Interface
;
73 type Interrupt_List
is array (Interrupt_ID
range <>) of Interrupt_ID
;
74 Exception_Interrupts
: constant Interrupt_List
:=
75 (SIGFPE
, SIGILL
, SIGSEGV
, SIGBUS
);
77 Unreserve_All_Interrupts
: Interfaces
.C
.int
;
79 (C
, Unreserve_All_Interrupts
, "__gl_unreserve_all_interrupts");
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
85 function State
(Int
: Interrupt_ID
) return Character;
86 pragma Import
(C
, State
, "__gnat_get_interrupt_state");
87 -- Get interrupt state. Defined in init.c
88 -- The input argument is the interrupt number,
89 -- and the result is one of the following:
91 User
: constant Character := 'u';
92 Runtime
: constant Character := 'r';
93 Default
: constant Character := 's';
94 -- 'n' this interrupt not set by any Interrupt_State pragma
95 -- 'u' Interrupt_State pragma set state to User
96 -- 'r' Interrupt_State pragma set state to Runtime
97 -- 's' Interrupt_State pragma set state to System (use "default"
100 procedure Notify_Exception
102 siginfo
: System
.Address
;
103 ucontext
: System
.Address
);
104 -- This function identifies the Ada exception to be raised using
105 -- the information when the system received a synchronous signal.
106 -- Since this function is machine and OS dependent, different code
107 -- has to be provided for different target.
109 ----------------------
110 -- Notify_Exception --
111 ----------------------
113 Signal_Mask
: aliased sigset_t
;
114 -- The set of signals handled by Notify_Exception
116 procedure Notify_Exception
118 siginfo
: System
.Address
;
119 ucontext
: System
.Address
)
121 pragma Unreferenced
(siginfo
);
123 -- The GCC unwinder requires adjustments to the signal's machine
124 -- context to be able to properly unwind through the signal handler.
125 -- This is achieved by the target specific subprogram below, provided
126 -- by init.c to be usable by the non-tasking handler also.
128 procedure Adjust_Context_For_Raise
130 ucontext
: System
.Address
);
132 (C
, Adjust_Context_For_Raise
, "__gnat_adjust_context_for_raise");
134 Result
: Interfaces
.C
.int
;
137 -- With the __builtin_longjmp, the signal mask is not restored, so we
138 -- need to restore it explicitely.
140 Result
:= pthread_sigmask
(SIG_UNBLOCK
, Signal_Mask
'Access, null);
141 pragma Assert
(Result
= 0);
143 -- Perform the necessary context adjustments required by the GCC/ZCX
144 -- unwinder, harmless in the SJLJ case.
146 Adjust_Context_For_Raise
(signo
, ucontext
);
148 -- Check that treatment of exception propagation here
149 -- is consistent with treatment of the abort signal in
150 -- System.Task_Primitives.Operations.
154 raise Constraint_Error
;
164 end Notify_Exception
;
170 Initialized
: Boolean := False;
172 procedure Initialize
is
173 act
: aliased struct_sigaction
;
174 old_act
: aliased struct_sigaction
;
175 Result
: System
.OS_Interface
.int
;
184 -- Need to call pthread_init very early because it is doing signal
189 Abort_Task_Interrupt
:= SIGADAABORT
;
191 act
.sa_handler
:= Notify_Exception
'Address;
193 act
.sa_flags
:= SA_SIGINFO
;
195 -- Setting SA_SIGINFO asks the kernel to pass more than just the signal
196 -- number argument to the handler when it is called. The set of extra
197 -- parameters includes a pointer to the interrupted context, which the
198 -- ZCX propagation scheme needs.
200 -- Most man pages for sigaction mention that sa_sigaction should be set
201 -- instead of sa_handler when SA_SIGINFO is on. In practice, the two
202 -- fields are actually union'ed and located at the same offset.
204 -- On some targets, we set sa_flags to SA_NODEFER so that during the
205 -- handler execution we do not change the Signal_Mask to be masked for
208 -- This is a temporary fix to the problem that the Signal_Mask is
209 -- not restored after the exception (longjmp) from the handler.
210 -- The right fix should be made in sigsetjmp so that we save
211 -- the Signal_Set and restore it after a longjmp.
213 -- Since SA_NODEFER is obsolete, instead we reset explicitely
214 -- the mask in the exception handler.
216 Result
:= sigemptyset
(Signal_Mask
'Access);
217 pragma Assert
(Result
= 0);
219 -- Add signals that map to Ada exceptions to the mask.
220 for J
in Exception_Interrupts
'Range loop
221 if State
(Exception_Interrupts
(J
)) /= Default
then
223 sigaddset
(Signal_Mask
'Access, Signal
(Exception_Interrupts
(J
)));
224 pragma Assert
(Result
= 0);
228 act
.sa_mask
:= Signal_Mask
;
230 pragma Assert
(Keep_Unmasked
= (Interrupt_ID
'Range => False));
231 pragma Assert
(Reserve
= (Interrupt_ID
'Range => False));
233 -- Process state of exception signals
234 for J
in Exception_Interrupts
'Range loop
235 if State
(Exception_Interrupts
(J
)) /= User
then
236 Keep_Unmasked
(Exception_Interrupts
(J
)) := True;
237 Reserve
(Exception_Interrupts
(J
)) := True;
239 if State
(Exception_Interrupts
(J
)) /= Default
then
242 (Signal
(Exception_Interrupts
(J
)), act
'Unchecked_Access,
243 old_act
'Unchecked_Access);
244 pragma Assert
(Result
= 0);
249 if State
(Abort_Task_Interrupt
) /= User
then
250 Keep_Unmasked
(Abort_Task_Interrupt
) := True;
251 Reserve
(Abort_Task_Interrupt
) := True;
254 -- Set SIGINT to unmasked state as long as it is not in "User"
255 -- state. Check for Unreserve_All_Interrupts last
257 if State
(SIGINT
) /= User
then
258 Keep_Unmasked
(SIGINT
) := True;
259 Reserve
(SIGINT
) := True;
262 -- Check all signals for state that requires keeping them
263 -- unmasked and reserved
265 for J
in Interrupt_ID
'Range loop
266 if State
(J
) = Default
or else State
(J
) = Runtime
then
267 Keep_Unmasked
(J
) := True;
272 -- Add the set of signals that must always be unmasked for this target
274 for J
in Unmasked
'Range loop
275 Keep_Unmasked
(Interrupt_ID
(Unmasked
(J
))) := True;
276 Reserve
(Interrupt_ID
(Unmasked
(J
))) := True;
279 -- Add target-specific reserved signals
281 for J
in Reserved
'Range loop
282 Reserve
(Interrupt_ID
(Reserved
(J
))) := True;
285 -- Process pragma Unreserve_All_Interrupts. This overrides any
286 -- settings due to pragma Interrupt_State:
288 if Unreserve_All_Interrupts
/= 0 then
289 Keep_Unmasked
(SIGINT
) := False;
290 Reserve
(SIGINT
) := False;
293 -- We do not have Signal 0 in reality. We just use this value
294 -- to identify non-existent signals (see s-intnam.ads). Therefore,
295 -- Signal 0 should not be used in all signal related operations hence
296 -- mark it as reserved.
301 end System
.Interrupt_Management
;