1------------------------------------------------------------------------------ 2-- -- 3-- GNU ADA 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-2003, Ada Core Technologies -- 11-- -- 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, 59 Temple Place - Suite 330, Boston, -- 21-- MA 02111-1307, USA. -- 22-- -- 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. -- 29-- -- 30-- GNARL was developed by the GNARL team at Florida State University. -- 31-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 32-- -- 33------------------------------------------------------------------------------ 34 35-- This is a POSIX-like version of this package. 36-- Note: this file can only be used for POSIX compliant systems. 37 38with Interfaces.C; 39-- used for int 40-- size_t 41-- unsigned 42 43with System.OS_Interface; 44-- used for various type, constant, and operations 45 46with System.Storage_Elements; 47-- used for To_Address 48-- Integer_Address 49 50with Unchecked_Conversion; 51 52package body System.Interrupt_Management.Operations is 53 54 use Interfaces.C; 55 use System.OS_Interface; 56 57 type Interrupt_Mask_Ptr is access all Interrupt_Mask; 58 59 function "+" is new 60 Unchecked_Conversion (Interrupt_Mask_Ptr, sigset_t_ptr); 61 62 --------------------- 63 -- Local Variables -- 64 --------------------- 65 66 Initial_Action : array (Signal) of aliased struct_sigaction; 67 68 Default_Action : aliased struct_sigaction; 69 70 Ignore_Action : aliased struct_sigaction; 71 72 ---------------------------- 73 -- Thread_Block_Interrupt -- 74 ---------------------------- 75 76 procedure Thread_Block_Interrupt 77 (Interrupt : Interrupt_ID) 78 is 79 Result : Interfaces.C.int; 80 Mask : aliased sigset_t; 81 82 begin 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; 90 91 ------------------------------ 92 -- Thread_Unblock_Interrupt -- 93 ------------------------------ 94 95 procedure Thread_Unblock_Interrupt 96 (Interrupt : Interrupt_ID) 97 is 98 Mask : aliased sigset_t; 99 Result : Interfaces.C.int; 100 101 begin 102 Result := sigemptyset (Mask'Access); 103 pragma Assert (Result = 0); 104 Result := sigaddset (Mask'Access, Signal (Interrupt)); 105 pragma Assert (Result = 0); 106 Result := pthread_sigmask (SIG_UNBLOCK, Mask'Unchecked_Access, null); 107 pragma Assert (Result = 0); 108 end Thread_Unblock_Interrupt; 109 110 ------------------------ 111 -- Set_Interrupt_Mask -- 112 ------------------------ 113 114 procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is 115 Result : Interfaces.C.int; 116 117 begin 118 Result := pthread_sigmask 119 (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), null); 120 pragma Assert (Result = 0); 121 end Set_Interrupt_Mask; 122 123 procedure Set_Interrupt_Mask 124 (Mask : access Interrupt_Mask; 125 OMask : access Interrupt_Mask) 126 is 127 Result : Interfaces.C.int; 128 129 begin 130 Result := pthread_sigmask 131 (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), +Interrupt_Mask_Ptr (OMask)); 132 pragma Assert (Result = 0); 133 end Set_Interrupt_Mask; 134 135 ------------------------ 136 -- Get_Interrupt_Mask -- 137 ------------------------ 138 139 procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is 140 Result : Interfaces.C.int; 141 142 begin 143 Result := pthread_sigmask 144 (SIG_SETMASK, null, +Interrupt_Mask_Ptr (Mask)); 145 pragma Assert (Result = 0); 146 end Get_Interrupt_Mask; 147 148 -------------------- 149 -- Interrupt_Wait -- 150 -------------------- 151 152 function Interrupt_Wait 153 (Mask : access Interrupt_Mask) 154 return Interrupt_ID 155 is 156 Result : Interfaces.C.int; 157 Sig : aliased Signal; 158 159 begin 160 Result := sigwait (Mask, Sig'Access); 161 162 if Result /= 0 then 163 return 0; 164 end if; 165 166 return Interrupt_ID (Sig); 167 end Interrupt_Wait; 168 169 ---------------------------- 170 -- Install_Default_Action -- 171 ---------------------------- 172 173 procedure Install_Default_Action (Interrupt : Interrupt_ID) is 174 Result : Interfaces.C.int; 175 176 begin 177 Result := sigaction 178 (Signal (Interrupt), 179 Initial_Action (Signal (Interrupt))'Access, null); 180 pragma Assert (Result = 0); 181 end Install_Default_Action; 182 183 --------------------------- 184 -- Install_Ignore_Action -- 185 --------------------------- 186 187 procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is 188 Result : Interfaces.C.int; 189 190 begin 191 Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null); 192 pragma Assert (Result = 0); 193 end Install_Ignore_Action; 194 195 ------------------------- 196 -- Fill_Interrupt_Mask -- 197 ------------------------- 198 199 procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is 200 Result : Interfaces.C.int; 201 202 begin 203 Result := sigfillset (Mask); 204 pragma Assert (Result = 0); 205 end Fill_Interrupt_Mask; 206 207 -------------------------- 208 -- Empty_Interrupt_Mask -- 209 -------------------------- 210 211 procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is 212 Result : Interfaces.C.int; 213 214 begin 215 Result := sigemptyset (Mask); 216 pragma Assert (Result = 0); 217 end Empty_Interrupt_Mask; 218 219 --------------------------- 220 -- Add_To_Interrupt_Mask -- 221 --------------------------- 222 223 procedure Add_To_Interrupt_Mask 224 (Mask : access Interrupt_Mask; 225 Interrupt : Interrupt_ID) 226 is 227 Result : Interfaces.C.int; 228 229 begin 230 Result := sigaddset (Mask, Signal (Interrupt)); 231 pragma Assert (Result = 0); 232 end Add_To_Interrupt_Mask; 233 234 -------------------------------- 235 -- Delete_From_Interrupt_Mask -- 236 -------------------------------- 237 238 procedure Delete_From_Interrupt_Mask 239 (Mask : access Interrupt_Mask; 240 Interrupt : Interrupt_ID) 241 is 242 Result : Interfaces.C.int; 243 244 begin 245 Result := sigdelset (Mask, Signal (Interrupt)); 246 pragma Assert (Result = 0); 247 end Delete_From_Interrupt_Mask; 248 249 --------------- 250 -- Is_Member -- 251 --------------- 252 253 function Is_Member 254 (Mask : access Interrupt_Mask; 255 Interrupt : Interrupt_ID) return Boolean 256 is 257 Result : Interfaces.C.int; 258 259 begin 260 Result := sigismember (Mask, Signal (Interrupt)); 261 pragma Assert (Result = 0 or else Result = 1); 262 return Result = 1; 263 end Is_Member; 264 265 ------------------------- 266 -- Copy_Interrupt_Mask -- 267 ------------------------- 268 269 procedure Copy_Interrupt_Mask 270 (X : out Interrupt_Mask; 271 Y : Interrupt_Mask) 272 is 273 begin 274 X := Y; 275 end Copy_Interrupt_Mask; 276 277 ---------------------------- 278 -- Interrupt_Self_Process -- 279 ---------------------------- 280 281 procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is 282 Result : Interfaces.C.int; 283 284 begin 285 Result := kill (getpid, Signal (Interrupt)); 286 pragma Assert (Result = 0); 287 end Interrupt_Self_Process; 288 289begin 290 291 declare 292 mask : aliased sigset_t; 293 allmask : aliased sigset_t; 294 Result : Interfaces.C.int; 295 296 begin 297 for Sig in 1 .. Signal'Last loop 298 Result := sigaction 299 (Sig, null, Initial_Action (Sig)'Unchecked_Access); 300 301 -- ??? [assert 1] 302 -- we can't check Result here since sigaction will fail on 303 -- SIGKILL, SIGSTOP, and possibly other signals 304 -- pragma Assert (Result = 0); 305 306 end loop; 307 308 -- Setup the masks to be exported. 309 310 Result := sigemptyset (mask'Access); 311 pragma Assert (Result = 0); 312 313 Result := sigfillset (allmask'Access); 314 pragma Assert (Result = 0); 315 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)); 321 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)); 327 328 for J in Interrupt_ID loop 329 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. 333 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); 339 end if; 340 end loop; 341 342 -- The Keep_Unmasked signals should be unmasked for Environment task 343 344 Result := pthread_sigmask (SIG_UNBLOCK, mask'Unchecked_Access, null); 345 pragma Assert (Result = 0); 346 347 -- Get the signal mask of the Environment Task 348 349 Result := pthread_sigmask (SIG_SETMASK, null, mask'Unchecked_Access); 350 pragma Assert (Result = 0); 351 352 -- Setup the constants exported 353 354 Environment_Mask := Interrupt_Mask (mask); 355 356 All_Tasks_Mask := Interrupt_Mask (allmask); 357 end; 358 359end System.Interrupt_Management.Operations; 360