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-2005, 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 with Unchecked_Conversion;
  52
  53 package body System.Interrupt_Management.Operations is
  54
  55    use Interfaces.C;
  56    use System.OS_Interface;
  57
  58    type Interrupt_Mask_Ptr is access all Interrupt_Mask;
  59
  60    function "+" is new
  61      Unchecked_Conversion (Interrupt_Mask_Ptr, sigset_t_ptr);
  62
  63    ---------------------
  64    -- Local Variables --
  65    ---------------------
  66
  67    Initial_Action : array (Signal) of aliased struct_sigaction;
  68
  69    Default_Action : aliased struct_sigaction;
  70
  71    Ignore_Action  : aliased struct_sigaction;
  72
  73    ----------------------------
  74    -- Thread_Block_Interrupt --
  75    ----------------------------
  76
  77    procedure Thread_Block_Interrupt
  78      (Interrupt : Interrupt_ID)
  79    is
  80       Result : Interfaces.C.int;
  81       Mask   : aliased sigset_t;
  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    begin
 101       Result := sigemptyset (Mask'Access);
 102       pragma Assert (Result = 0);
 103       Result := sigaddset (Mask'Access, Signal (Interrupt));
 104       pragma Assert (Result = 0);
 105       Result := pthread_sigmask (SIG_UNBLOCK, Mask'Unchecked_Access, null);
 106       pragma Assert (Result = 0);
 107    end Thread_Unblock_Interrupt;
 108
 109    ------------------------
 110    -- Set_Interrupt_Mask --
 111    ------------------------
 112
 113    procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
 114       Result   : Interfaces.C.int;
 115    begin
 116       Result := pthread_sigmask
 117         (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), null);
 118       pragma Assert (Result = 0);
 119    end Set_Interrupt_Mask;
 120
 121    procedure Set_Interrupt_Mask
 122      (Mask  : access Interrupt_Mask;
 123       OMask : access Interrupt_Mask)
 124    is
 125       Result  : Interfaces.C.int;
 126    begin
 127       Result := pthread_sigmask
 128         (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), +Interrupt_Mask_Ptr (OMask));
 129       pragma Assert (Result = 0);
 130    end Set_Interrupt_Mask;
 131
 132    ------------------------
 133    -- Get_Interrupt_Mask --
 134    ------------------------
 135
 136    procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
 137       Result : Interfaces.C.int;
 138    begin
 139       Result := pthread_sigmask
 140         (SIG_SETMASK, null, +Interrupt_Mask_Ptr (Mask));
 141       pragma Assert (Result = 0);
 142    end Get_Interrupt_Mask;
 143
 144    --------------------
 145    -- Interrupt_Wait --
 146    --------------------
 147
 148    function Interrupt_Wait
 149      (Mask : access Interrupt_Mask)
 150       return Interrupt_ID
 151    is
 152       Result : Interfaces.C.int;
 153       Sig    : aliased Signal;
 154    begin
 155       Result := sigwait (Mask, Sig'Access);
 156
 157       if Result /= 0 then
 158          return 0;
 159       end if;
 160
 161       return Interrupt_ID (Sig);
 162    end Interrupt_Wait;
 163
 164    ----------------------------
 165    -- Install_Default_Action --
 166    ----------------------------
 167
 168    procedure Install_Default_Action (Interrupt : Interrupt_ID) is
 169       Result : Interfaces.C.int;
 170    begin
 171       Result := sigaction
 172         (Signal (Interrupt),
 173          Initial_Action (Signal (Interrupt))'Access, null);
 174       pragma Assert (Result = 0);
 175    end Install_Default_Action;
 176
 177    ---------------------------
 178    -- Install_Ignore_Action --
 179    ---------------------------
 180
 181    procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
 182       Result : Interfaces.C.int;
 183    begin
 184       Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
 185       pragma Assert (Result = 0);
 186    end Install_Ignore_Action;
 187
 188    -------------------------
 189    -- Fill_Interrupt_Mask --
 190    -------------------------
 191
 192    procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
 193       Result : Interfaces.C.int;
 194    begin
 195       Result := sigfillset (Mask);
 196       pragma Assert (Result = 0);
 197    end Fill_Interrupt_Mask;
 198
 199    --------------------------
 200    -- Empty_Interrupt_Mask --
 201    --------------------------
 202
 203    procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
 204       Result : Interfaces.C.int;
 205    begin
 206       Result := sigemptyset (Mask);
 207       pragma Assert (Result = 0);
 208    end Empty_Interrupt_Mask;
 209
 210    ---------------------------
 211    -- Add_To_Interrupt_Mask --
 212    ---------------------------
 213
 214    procedure Add_To_Interrupt_Mask
 215      (Mask      : access Interrupt_Mask;
 216       Interrupt : Interrupt_ID)
 217    is
 218       Result : Interfaces.C.int;
 219    begin
 220       Result := sigaddset (Mask, Signal (Interrupt));
 221       pragma Assert (Result = 0);
 222    end Add_To_Interrupt_Mask;
 223
 224    --------------------------------
 225    -- Delete_From_Interrupt_Mask --
 226    --------------------------------
 227
 228    procedure Delete_From_Interrupt_Mask
 229      (Mask      : access Interrupt_Mask;
 230       Interrupt : Interrupt_ID)
 231    is
 232       Result : Interfaces.C.int;
 233    begin
 234       Result := sigdelset (Mask, Signal (Interrupt));
 235       pragma Assert (Result = 0);
 236    end Delete_From_Interrupt_Mask;
 237
 238    ---------------
 239    -- Is_Member --
 240    ---------------
 241
 242    function Is_Member
 243      (Mask      : access Interrupt_Mask;
 244       Interrupt : Interrupt_ID) return Boolean
 245    is
 246       Result : Interfaces.C.int;
 247    begin
 248       Result := sigismember (Mask, Signal (Interrupt));
 249       pragma Assert (Result = 0 or else Result = 1);
 250       return Result = 1;
 251    end Is_Member;
 252
 253    -------------------------
 254    -- Copy_Interrupt_Mask --
 255    -------------------------
 256
 257    procedure Copy_Interrupt_Mask
 258      (X : out Interrupt_Mask;
 259       Y : Interrupt_Mask) is
 260    begin
 261       X := Y;
 262    end Copy_Interrupt_Mask;
 263
 264    ----------------------------
 265    -- Interrupt_Self_Process --
 266    ----------------------------
 267
 268    procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
 269       Result : Interfaces.C.int;
 270    begin
 271       Result := kill (getpid, Signal (Interrupt));
 272       pragma Assert (Result = 0);
 273    end Interrupt_Self_Process;
 274
 275    --------------------------
 276    -- Setup_Interrupt_Mask --
 277    --------------------------
 278
 279    procedure Setup_Interrupt_Mask is
 280    begin
 281       --  Mask task for all signals. The original mask of the Environment task
 282       --  will be recovered by Interrupt_Manager task during the elaboration
 283       --  of s-interr.adb.
 284
 285       Set_Interrupt_Mask (All_Tasks_Mask'Access);
 286    end Setup_Interrupt_Mask;
 287
 288 begin
 289    declare
 290       mask    : aliased sigset_t;
 291       allmask : aliased sigset_t;
 292       Result  : Interfaces.C.int;
 293
 294    begin
 295       Interrupt_Management.Initialize;
 296
 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;