1------------------------------------------------------------------------------
2--                                                                          --
3--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
4--                                                                          --
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--                                                                          --
7--                                  B o d y                                 --
8--                                                                          --
9--          Copyright (C) 1992-2019, Free Software Foundation, Inc.         --
10--                                                                          --
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 3,  or (at your option) any later ver- --
14-- sion.  GNAT 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.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNARL was developed by the GNARL team at Florida State University.       --
28-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
29--                                                                          --
30------------------------------------------------------------------------------
31
32--  This is a Solaris version of this package
33
34--  Make a careful study of all signals available under the OS, to see which
35--  need to be reserved, kept always unmasked, or kept always unmasked.
36
37--  Be on the lookout for special signals that may be used by the thread
38--  library.
39
40package body System.Interrupt_Management is
41
42   use Interfaces.C;
43   use System.OS_Interface;
44
45   type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
46
47   Exception_Interrupts : constant Interrupt_List :=
48     (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
49
50   Unreserve_All_Interrupts : Interfaces.C.int;
51   pragma Import
52     (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
53
54   function State (Int : Interrupt_ID) return Character;
55   pragma Import (C, State, "__gnat_get_interrupt_state");
56   --  Get interrupt state.  Defined in init.c
57   --  The input argument is the interrupt number,
58   --  and the result is one of the following:
59
60   User    : constant Character := 'u';
61   Runtime : constant Character := 'r';
62   Default : constant Character := 's';
63   --    'n'   this interrupt not set by any Interrupt_State pragma
64   --    'u'   Interrupt_State pragma set state to User
65   --    'r'   Interrupt_State pragma set state to Runtime
66   --    's'   Interrupt_State pragma set state to System (use "default"
67   --           system handler)
68
69   ----------------------
70   -- Notify_Exception --
71   ----------------------
72
73   --  This function identifies the Ada exception to be raised using the
74   --  information when the system received a synchronous signal. Since this
75   --  function is machine and OS dependent, different code has to be provided
76   --  for different target.
77
78   procedure Notify_Exception
79     (signo   : Signal;
80      info    : access siginfo_t;
81      context : access ucontext_t);
82
83   ----------------------
84   -- Notify_Exception --
85   ----------------------
86
87   procedure Notify_Exception
88     (signo   : Signal;
89      info    : access siginfo_t;
90      context : access ucontext_t)
91   is
92      pragma Unreferenced (info);
93
94   begin
95      --  Perform the necessary context adjustments prior to a raise from a
96      --  signal handler.
97
98      Adjust_Context_For_Raise (signo, context.all'Address);
99
100      --  Check that treatment of exception propagation here is consistent with
101      --  treatment of the abort signal in System.Task_Primitives.Operations.
102
103      case signo is
104         when SIGFPE  => raise Constraint_Error;
105         when SIGILL  => raise Program_Error;
106         when SIGSEGV => raise Storage_Error;
107         when SIGBUS  => raise Storage_Error;
108         when others  => null;
109      end case;
110   end Notify_Exception;
111
112   ----------------
113   -- Initialize --
114   ----------------
115
116   Initialized : Boolean := False;
117
118   procedure Initialize is
119      act     : aliased struct_sigaction;
120      old_act : aliased struct_sigaction;
121      mask    : aliased sigset_t;
122      Result  : Interfaces.C.int;
123
124   begin
125      if Initialized then
126         return;
127      end if;
128
129      Initialized := True;
130
131      --  Need to call pthread_init very early because it is doing signal
132      --  initializations.
133
134      pthread_init;
135
136      --  Change this if you want to use another signal for task abort.
137      --  SIGTERM might be a good one.
138
139      Abort_Task_Interrupt := SIGABRT;
140
141      act.sa_handler := Notify_Exception'Address;
142
143      --  Set sa_flags to SA_NODEFER so that during the handler execution
144      --  we do not change the Signal_Mask to be masked for the Signal.
145      --  This is a temporary fix to the problem that the Signal_Mask is
146      --  not restored after the exception (longjmp) from the handler.
147      --  The right fix should be made in sigsetjmp so that we save
148      --  the Signal_Set and restore it after a longjmp.
149
150      --  In that case, this field should be changed back to 0. ??? (Dong-Ik)
151
152      act.sa_flags := 16;
153
154      Result := sigemptyset (mask'Access);
155      pragma Assert (Result = 0);
156
157      --  ??? For the same reason explained above, we can't mask these signals
158      --  because otherwise we won't be able to catch more than one signal.
159
160      act.sa_mask := mask;
161
162      pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
163      pragma Assert (Reserve = (Interrupt_ID'Range => False));
164
165      for J in Exception_Interrupts'Range loop
166         if State (Exception_Interrupts (J)) /= User then
167            Keep_Unmasked (Exception_Interrupts (J)) := True;
168            Reserve (Exception_Interrupts (J)) := True;
169
170            if State (Exception_Interrupts (J)) /= Default then
171               Result :=
172                 sigaction
173                 (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
174                  old_act'Unchecked_Access);
175               pragma Assert (Result = 0);
176            end if;
177         end if;
178      end loop;
179
180      if State (Abort_Task_Interrupt) /= User then
181         Keep_Unmasked (Abort_Task_Interrupt) := True;
182         Reserve (Abort_Task_Interrupt) := True;
183      end if;
184
185      --  Set SIGINT to unmasked state as long as it's
186      --  not in "User" state.  Check for Unreserve_All_Interrupts last
187
188      if State (SIGINT) /= User then
189         Keep_Unmasked (SIGINT) := True;
190         Reserve (SIGINT) := True;
191      end if;
192
193      --  Check all signals for state that requires keeping them
194      --  unmasked and reserved
195
196      for J in Interrupt_ID'Range loop
197         if State (J) = Default or else State (J) = Runtime then
198            Keep_Unmasked (J) := True;
199            Reserve (J) := True;
200         end if;
201      end loop;
202
203      --  Add the set of signals that must always be unmasked for this target
204
205      for J in Unmasked'Range loop
206         Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
207         Reserve (Interrupt_ID (Unmasked (J))) := True;
208      end loop;
209
210      --  Add target-specific reserved signals
211
212      for J in Reserved'Range loop
213         Reserve (Interrupt_ID (Reserved (J))) := True;
214      end loop;
215
216      --  Process pragma Unreserve_All_Interrupts. This overrides any
217      --  settings due to pragma Interrupt_State:
218
219      if Unreserve_All_Interrupts /= 0 then
220         Keep_Unmasked (SIGINT) := False;
221         Reserve (SIGINT) := False;
222      end if;
223
224      --  We do not have Signal 0 in reality. We just use this value to
225      --  identify not existing signals (see s-intnam.ads). Therefore, Signal 0
226      --  should not be used in all signal related operations hence mark it as
227      --  reserved.
228
229      Reserve (0) := True;
230   end Initialize;
231
232end System.Interrupt_Management;
233