gcc/ada/s-inmaop-posix.adb

   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
  37 with Interfaces.C;
  38
  39 with System.OS_Interface;
  40 with System.Storage_Elements;
  41
  42 package 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
 270 begin
 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
 336 end System.Interrupt_Management.Operations;