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-1994, Florida State University            --
10--                     Copyright (C) 1995-2010, 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
37with Interfaces.C;
38
39with System.OS_Interface;
40with System.Storage_Elements;
41
42package 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
270begin
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
336end System.Interrupt_Management.Operations;
337