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-2008, AdaCore                     --
  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,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, 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
  37 --  Note: this file can only be used for POSIX compliant systems
  38
  39 with Interfaces.C;
  40
  41 with System.OS_Interface;
  42 with System.Storage_Elements;
  43
  44 package body System.Interrupt_Management.Operations is
  45
  46    use Interfaces.C;
  47    use System.OS_Interface;
  48
  49    ---------------------
  50    -- Local Variables --
  51    ---------------------
  52
  53    Initial_Action : array (Signal) of aliased struct_sigaction;
  54
  55    Default_Action : aliased struct_sigaction;
  56    pragma Warnings (Off, Default_Action);
  57
  58    Ignore_Action : aliased struct_sigaction;
  59
  60    ----------------------------
  61    -- Thread_Block_Interrupt --
  62    ----------------------------
  63
  64    procedure Thread_Block_Interrupt
  65      (Interrupt : Interrupt_ID)
  66    is
  67       Result : Interfaces.C.int;
  68       Mask   : aliased sigset_t;
  69    begin
  70       Result := sigemptyset (Mask'Access);
  71       pragma Assert (Result = 0);
  72       Result := sigaddset (Mask'Access, Signal (Interrupt));
  73       pragma Assert (Result = 0);
  74       Result := pthread_sigmask (SIG_BLOCK, Mask'Access, null);
  75       pragma Assert (Result = 0);
  76    end Thread_Block_Interrupt;
  77
  78    ------------------------------
  79    -- Thread_Unblock_Interrupt --
  80    ------------------------------
  81
  82    procedure Thread_Unblock_Interrupt
  83      (Interrupt : Interrupt_ID)
  84    is
  85       Mask   : aliased sigset_t;
  86       Result : Interfaces.C.int;
  87    begin
  88       Result := sigemptyset (Mask'Access);
  89       pragma Assert (Result = 0);
  90       Result := sigaddset (Mask'Access, Signal (Interrupt));
  91       pragma Assert (Result = 0);
  92       Result := pthread_sigmask (SIG_UNBLOCK, Mask'Access, null);
  93       pragma Assert (Result = 0);
  94    end Thread_Unblock_Interrupt;
  95
  96    ------------------------
  97    -- Set_Interrupt_Mask --
  98    ------------------------
  99
 100    procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
 101       Result : Interfaces.C.int;
 102    begin
 103       Result := pthread_sigmask (SIG_SETMASK, Mask, null);
 104       pragma Assert (Result = 0);
 105    end Set_Interrupt_Mask;
 106
 107    procedure Set_Interrupt_Mask
 108      (Mask  : access Interrupt_Mask;
 109       OMask : access Interrupt_Mask)
 110    is
 111       Result  : Interfaces.C.int;
 112    begin
 113       Result := pthread_sigmask (SIG_SETMASK, Mask, OMask);
 114       pragma Assert (Result = 0);
 115    end Set_Interrupt_Mask;
 116
 117    ------------------------
 118    -- Get_Interrupt_Mask --
 119    ------------------------
 120
 121    procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
 122       Result : Interfaces.C.int;
 123    begin
 124       Result := pthread_sigmask (SIG_SETMASK, null, Mask);
 125       pragma Assert (Result = 0);
 126    end Get_Interrupt_Mask;
 127
 128    --------------------
 129    -- Interrupt_Wait --
 130    --------------------
 131
 132    function Interrupt_Wait
 133      (Mask : access Interrupt_Mask) return Interrupt_ID
 134    is
 135       Result : Interfaces.C.int;
 136       Sig    : aliased Signal;
 137
 138    begin
 139       Result := sigwait (Mask, Sig'Access);
 140
 141       if Result /= 0 then
 142          return 0;
 143       end if;
 144
 145       return Interrupt_ID (Sig);
 146    end Interrupt_Wait;
 147
 148    ----------------------------
 149    -- Install_Default_Action --
 150    ----------------------------
 151
 152    procedure Install_Default_Action (Interrupt : Interrupt_ID) is
 153       Result : Interfaces.C.int;
 154    begin
 155       Result := sigaction
 156         (Signal (Interrupt),
 157          Initial_Action (Signal (Interrupt))'Access, null);
 158       pragma Assert (Result = 0);
 159    end Install_Default_Action;
 160
 161    ---------------------------
 162    -- Install_Ignore_Action --
 163    ---------------------------
 164
 165    procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
 166       Result : Interfaces.C.int;
 167    begin
 168       Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
 169       pragma Assert (Result = 0);
 170    end Install_Ignore_Action;
 171
 172    -------------------------
 173    -- Fill_Interrupt_Mask --
 174    -------------------------
 175
 176    procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
 177       Result : Interfaces.C.int;
 178    begin
 179       Result := sigfillset (Mask);
 180       pragma Assert (Result = 0);
 181    end Fill_Interrupt_Mask;
 182
 183    --------------------------
 184    -- Empty_Interrupt_Mask --
 185    --------------------------
 186
 187    procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
 188       Result : Interfaces.C.int;
 189    begin
 190       Result := sigemptyset (Mask);
 191       pragma Assert (Result = 0);
 192    end Empty_Interrupt_Mask;
 193
 194    ---------------------------
 195    -- Add_To_Interrupt_Mask --
 196    ---------------------------
 197
 198    procedure Add_To_Interrupt_Mask
 199      (Mask      : access Interrupt_Mask;
 200       Interrupt : Interrupt_ID)
 201    is
 202       Result : Interfaces.C.int;
 203    begin
 204       Result := sigaddset (Mask, Signal (Interrupt));
 205       pragma Assert (Result = 0);
 206    end Add_To_Interrupt_Mask;
 207
 208    --------------------------------
 209    -- Delete_From_Interrupt_Mask --
 210    --------------------------------
 211
 212    procedure Delete_From_Interrupt_Mask
 213      (Mask      : access Interrupt_Mask;
 214       Interrupt : Interrupt_ID)
 215    is
 216       Result : Interfaces.C.int;
 217    begin
 218       Result := sigdelset (Mask, Signal (Interrupt));
 219       pragma Assert (Result = 0);
 220    end Delete_From_Interrupt_Mask;
 221
 222    ---------------
 223    -- Is_Member --
 224    ---------------
 225
 226    function Is_Member
 227      (Mask      : access Interrupt_Mask;
 228       Interrupt : Interrupt_ID) return Boolean
 229    is
 230       Result : Interfaces.C.int;
 231    begin
 232       Result := sigismember (Mask, Signal (Interrupt));
 233       pragma Assert (Result = 0 or else Result = 1);
 234       return Result = 1;
 235    end Is_Member;
 236
 237    -------------------------
 238    -- Copy_Interrupt_Mask --
 239    -------------------------
 240
 241    procedure Copy_Interrupt_Mask
 242      (X : out Interrupt_Mask;
 243       Y : Interrupt_Mask) is
 244    begin
 245       X := Y;
 246    end Copy_Interrupt_Mask;
 247
 248    ----------------------------
 249    -- Interrupt_Self_Process --
 250    ----------------------------
 251
 252    procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
 253       Result : Interfaces.C.int;
 254    begin
 255       Result := kill (getpid, Signal (Interrupt));
 256       pragma Assert (Result = 0);
 257    end Interrupt_Self_Process;
 258
 259    --------------------------
 260    -- Setup_Interrupt_Mask --
 261    --------------------------
 262
 263    procedure Setup_Interrupt_Mask is
 264    begin
 265       --  Mask task for all signals. The original mask of the Environment task
 266       --  will be recovered by Interrupt_Manager task during the elaboration
 267       --  of s-interr.adb.
 268
 269       Set_Interrupt_Mask (All_Tasks_Mask'Access);
 270    end Setup_Interrupt_Mask;
 271
 272 begin
 273    declare
 274       mask    : aliased sigset_t;
 275       allmask : aliased sigset_t;
 276       Result  : Interfaces.C.int;
 277
 278    begin
 279       Interrupt_Management.Initialize;
 280
 281       for Sig in 1 .. Signal'Last loop
 282          Result := sigaction
 283            (Sig, null, Initial_Action (Sig)'Access);
 284
 285          --  ??? [assert 1]
 286          --  we can't check Result here since sigaction will fail on
 287          --  SIGKILL, SIGSTOP, and possibly other signals
 288          --  pragma Assert (Result = 0);
 289
 290       end loop;
 291
 292       --  Setup the masks to be exported
 293
 294       Result := sigemptyset (mask'Access);
 295       pragma Assert (Result = 0);
 296
 297       Result := sigfillset (allmask'Access);
 298       pragma Assert (Result = 0);
 299
 300       Default_Action.sa_flags   := 0;
 301       Default_Action.sa_mask    := mask;
 302       Default_Action.sa_handler :=
 303         Storage_Elements.To_Address
 304           (Storage_Elements.Integer_Address (SIG_DFL));
 305
 306       Ignore_Action.sa_flags   := 0;
 307       Ignore_Action.sa_mask    := mask;
 308       Ignore_Action.sa_handler :=
 309         Storage_Elements.To_Address
 310           (Storage_Elements.Integer_Address (SIG_IGN));
 311
 312       for J in Interrupt_ID loop
 313          if Keep_Unmasked (J) then
 314             Result := sigaddset (mask'Access, Signal (J));
 315             pragma Assert (Result = 0);
 316             Result := sigdelset (allmask'Access, Signal (J));
 317             pragma Assert (Result = 0);
 318          end if;
 319       end loop;
 320
 321       --  The Keep_Unmasked signals should be unmasked for Environment task
 322
 323       Result := pthread_sigmask (SIG_UNBLOCK, mask'Access, null);
 324       pragma Assert (Result = 0);
 325
 326       --  Get the signal mask of the Environment Task
 327
 328       Result := pthread_sigmask (SIG_SETMASK, null, mask'Access);
 329       pragma Assert (Result = 0);
 330
 331       --  Setup the constants exported
 332
 333       Environment_Mask := Interrupt_Mask (mask);
 334
 335       All_Tasks_Mask := Interrupt_Mask (allmask);
 336    end;
 337
 338 end System.Interrupt_Management.Operations;