gcc/ada/7sinmaop.adb

   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
  38 with Interfaces.C;
  39 --  used for int
  40 --           size_t
  41 --           unsigned
  42
  43 with System.OS_Interface;
  44 --  used for various type, constant, and operations
  45
  46 with System.Storage_Elements;
  47 --  used for To_Address
  48 --           Integer_Address
  49
  50 with Unchecked_Conversion;
  51
  52 package 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
 289 begin
 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
 359 end System.Interrupt_Management.Operations;