gcc/ada/s-inmaop-posix.adb

   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 --                            O P E R A T I O N S                           --
   7 --                                                                          --
   8 --                                  B o d y                                 --
   9 --                                                                          --
  10 --             Copyright (C) 1991-1994, Florida State University            --
  11 --                     Copyright (C) 1995-2006, AdaCore                     --
  12 --                                                                          --
  13 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  21 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  22 -- Boston, MA 02110-1301, USA.                                              --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNARL was developed by the GNARL team at Florida State University.       --
  32 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 --  This is a POSIX-like version of this package.
  37 --  Note: this file can only be used for POSIX compliant systems.
  38
  39 with Interfaces.C;
  40 --  used for int
  41 --           size_t
  42 --           unsigned
  43
  44 with System.OS_Interface;
  45 --  used for various type, constant, and operations
  46
  47 with System.Storage_Elements;
  48 --  used for To_Address
  49 --           Integer_Address
  50
  51 package body System.Interrupt_Management.Operations is
  52
  53    use Interfaces.C;
  54    use System.OS_Interface;
  55
  56    ---------------------
  57    -- Local Variables --
  58    ---------------------
  59
  60    Initial_Action : array (Signal) of aliased struct_sigaction;
  61
  62    Default_Action : aliased struct_sigaction;
  63
  64    Ignore_Action  : aliased struct_sigaction;
  65
  66    ----------------------------
  67    -- Thread_Block_Interrupt --
  68    ----------------------------
  69
  70    procedure Thread_Block_Interrupt
  71      (Interrupt : Interrupt_ID)
  72    is
  73       Result : Interfaces.C.int;
  74       Mask   : aliased sigset_t;
  75    begin
  76       Result := sigemptyset (Mask'Access);
  77       pragma Assert (Result = 0);
  78       Result := sigaddset (Mask'Access, Signal (Interrupt));
  79       pragma Assert (Result = 0);
  80       Result := pthread_sigmask (SIG_BLOCK, Mask'Unchecked_Access, null);
  81       pragma Assert (Result = 0);
  82    end Thread_Block_Interrupt;
  83
  84    ------------------------------
  85    -- Thread_Unblock_Interrupt --
  86    ------------------------------
  87
  88    procedure Thread_Unblock_Interrupt
  89      (Interrupt : Interrupt_ID)
  90    is
  91       Mask   : aliased sigset_t;
  92       Result : Interfaces.C.int;
  93    begin
  94       Result := sigemptyset (Mask'Access);
  95       pragma Assert (Result = 0);
  96       Result := sigaddset (Mask'Access, Signal (Interrupt));
  97       pragma Assert (Result = 0);
  98       Result := pthread_sigmask (SIG_UNBLOCK, Mask'Unchecked_Access, null);
  99       pragma Assert (Result = 0);
 100    end Thread_Unblock_Interrupt;
 101
 102    ------------------------
 103    -- Set_Interrupt_Mask --
 104    ------------------------
 105
 106    procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
 107       Result : Interfaces.C.int;
 108    begin
 109       Result := pthread_sigmask (SIG_SETMASK, Mask, null);
 110       pragma Assert (Result = 0);
 111    end Set_Interrupt_Mask;
 112
 113    procedure Set_Interrupt_Mask
 114      (Mask  : access Interrupt_Mask;
 115       OMask : access Interrupt_Mask)
 116    is
 117       Result  : Interfaces.C.int;
 118    begin
 119       Result := pthread_sigmask (SIG_SETMASK, Mask, OMask);
 120       pragma Assert (Result = 0);
 121    end Set_Interrupt_Mask;
 122
 123    ------------------------
 124    -- Get_Interrupt_Mask --
 125    ------------------------
 126
 127    procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
 128       Result : Interfaces.C.int;
 129    begin
 130       Result := pthread_sigmask (SIG_SETMASK, null, Mask);
 131       pragma Assert (Result = 0);
 132    end Get_Interrupt_Mask;
 133
 134    --------------------
 135    -- Interrupt_Wait --
 136    --------------------
 137
 138    function Interrupt_Wait
 139      (Mask : access Interrupt_Mask)
 140       return Interrupt_ID
 141    is
 142       Result : Interfaces.C.int;
 143       Sig    : aliased Signal;
 144    begin
 145       Result := sigwait (Mask, Sig'Access);
 146
 147       if Result /= 0 then
 148          return 0;
 149       end if;
 150
 151       return Interrupt_ID (Sig);
 152    end Interrupt_Wait;
 153
 154    ----------------------------
 155    -- Install_Default_Action --
 156    ----------------------------
 157
 158    procedure Install_Default_Action (Interrupt : Interrupt_ID) is
 159       Result : Interfaces.C.int;
 160    begin
 161       Result := sigaction
 162         (Signal (Interrupt),
 163          Initial_Action (Signal (Interrupt))'Access, null);
 164       pragma Assert (Result = 0);
 165    end Install_Default_Action;
 166
 167    ---------------------------
 168    -- Install_Ignore_Action --
 169    ---------------------------
 170
 171    procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
 172       Result : Interfaces.C.int;
 173    begin
 174       Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
 175       pragma Assert (Result = 0);
 176    end Install_Ignore_Action;
 177
 178    -------------------------
 179    -- Fill_Interrupt_Mask --
 180    -------------------------
 181
 182    procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
 183       Result : Interfaces.C.int;
 184    begin
 185       Result := sigfillset (Mask);
 186       pragma Assert (Result = 0);
 187    end Fill_Interrupt_Mask;
 188
 189    --------------------------
 190    -- Empty_Interrupt_Mask --
 191    --------------------------
 192
 193    procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
 194       Result : Interfaces.C.int;
 195    begin
 196       Result := sigemptyset (Mask);
 197       pragma Assert (Result = 0);
 198    end Empty_Interrupt_Mask;
 199
 200    ---------------------------
 201    -- Add_To_Interrupt_Mask --
 202    ---------------------------
 203
 204    procedure Add_To_Interrupt_Mask
 205      (Mask      : access Interrupt_Mask;
 206       Interrupt : Interrupt_ID)
 207    is
 208       Result : Interfaces.C.int;
 209    begin
 210       Result := sigaddset (Mask, Signal (Interrupt));
 211       pragma Assert (Result = 0);
 212    end Add_To_Interrupt_Mask;
 213
 214    --------------------------------
 215    -- Delete_From_Interrupt_Mask --
 216    --------------------------------
 217
 218    procedure Delete_From_Interrupt_Mask
 219      (Mask      : access Interrupt_Mask;
 220       Interrupt : Interrupt_ID)
 221    is
 222       Result : Interfaces.C.int;
 223    begin
 224       Result := sigdelset (Mask, Signal (Interrupt));
 225       pragma Assert (Result = 0);
 226    end Delete_From_Interrupt_Mask;
 227
 228    ---------------
 229    -- Is_Member --
 230    ---------------
 231
 232    function Is_Member
 233      (Mask      : access Interrupt_Mask;
 234       Interrupt : Interrupt_ID) return Boolean
 235    is
 236       Result : Interfaces.C.int;
 237    begin
 238       Result := sigismember (Mask, Signal (Interrupt));
 239       pragma Assert (Result = 0 or else Result = 1);
 240       return Result = 1;
 241    end Is_Member;
 242
 243    -------------------------
 244    -- Copy_Interrupt_Mask --
 245    -------------------------
 246
 247    procedure Copy_Interrupt_Mask
 248      (X : out Interrupt_Mask;
 249       Y : Interrupt_Mask) is
 250    begin
 251       X := Y;
 252    end Copy_Interrupt_Mask;
 253
 254    ----------------------------
 255    -- Interrupt_Self_Process --
 256    ----------------------------
 257
 258    procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
 259       Result : Interfaces.C.int;
 260    begin
 261       Result := kill (getpid, Signal (Interrupt));
 262       pragma Assert (Result = 0);
 263    end Interrupt_Self_Process;
 264
 265    --------------------------
 266    -- Setup_Interrupt_Mask --
 267    --------------------------
 268
 269    procedure Setup_Interrupt_Mask is
 270    begin
 271       --  Mask task for all signals. The original mask of the Environment task
 272       --  will be recovered by Interrupt_Manager task during the elaboration
 273       --  of s-interr.adb.
 274
 275       Set_Interrupt_Mask (All_Tasks_Mask'Access);
 276    end Setup_Interrupt_Mask;
 277
 278 begin
 279    declare
 280       mask    : aliased sigset_t;
 281       allmask : aliased sigset_t;
 282       Result  : Interfaces.C.int;
 283
 284    begin
 285       Interrupt_Management.Initialize;
 286
 287       for Sig in 1 .. Signal'Last loop
 288          Result := sigaction
 289            (Sig, null, Initial_Action (Sig)'Unchecked_Access);
 290
 291          --  ??? [assert 1]
 292          --  we can't check Result here since sigaction will fail on
 293          --  SIGKILL, SIGSTOP, and possibly other signals
 294          --  pragma Assert (Result = 0);
 295
 296       end loop;
 297
 298       --  Setup the masks to be exported
 299
 300       Result := sigemptyset (mask'Access);
 301       pragma Assert (Result = 0);
 302
 303       Result := sigfillset (allmask'Access);
 304       pragma Assert (Result = 0);
 305
 306       Default_Action.sa_flags   := 0;
 307       Default_Action.sa_mask    := mask;
 308       Default_Action.sa_handler :=
 309         Storage_Elements.To_Address
 310           (Storage_Elements.Integer_Address (SIG_DFL));
 311
 312       Ignore_Action.sa_flags   := 0;
 313       Ignore_Action.sa_mask    := mask;
 314       Ignore_Action.sa_handler :=
 315         Storage_Elements.To_Address
 316           (Storage_Elements.Integer_Address (SIG_IGN));
 317
 318       for J in Interrupt_ID loop
 319
 320          --  We need to check whether J is in Keep_Unmasked because
 321          --  the index type of the Keep_Unmasked array is not always
 322          --  Interrupt_ID; it may be a subtype of Interrupt_ID.
 323
 324          if J in Keep_Unmasked'Range and then Keep_Unmasked (J) then
 325             Result := sigaddset (mask'Access, Signal (J));
 326             pragma Assert (Result = 0);
 327             Result := sigdelset (allmask'Access, Signal (J));
 328             pragma Assert (Result = 0);
 329          end if;
 330       end loop;
 331
 332       --  The Keep_Unmasked signals should be unmasked for Environment task
 333
 334       Result := pthread_sigmask (SIG_UNBLOCK, mask'Unchecked_Access, null);
 335       pragma Assert (Result = 0);
 336
 337       --  Get the signal mask of the Environment Task
 338
 339       Result := pthread_sigmask (SIG_SETMASK, null, mask'Unchecked_Access);
 340       pragma Assert (Result = 0);
 341
 342       --  Setup the constants exported
 343
 344       Environment_Mask := Interrupt_Mask (mask);
 345
 346       All_Tasks_Mask := Interrupt_Mask (allmask);
 347    end;
 348
 349 end System.Interrupt_Management.Operations;