gcc/ada/s-inmaop-vms.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) 1992-2007, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This is a OpenVMS/Alpha version of this package
  35
  36 with System.OS_Interface;
  37 --  used for various type, constant, and operations
  38
  39 with System.Aux_DEC;
  40 --  used for Short_Address
  41
  42 with System.Parameters;
  43
  44 with System.Tasking;
  45
  46 with System.Tasking.Initialization;
  47
  48 with System.Task_Primitives.Operations;
  49
  50 with System.Task_Primitives.Operations.DEC;
  51
  52 with Ada.Unchecked_Conversion;
  53
  54 package body System.Interrupt_Management.Operations is
  55
  56    use System.OS_Interface;
  57    use System.Parameters;
  58    use System.Tasking;
  59    use type unsigned_short;
  60
  61    function To_Address is
  62      new Ada.Unchecked_Conversion (Task_Id, System.Address);
  63
  64    package POP renames System.Task_Primitives.Operations;
  65
  66    ----------------------------
  67    -- Thread_Block_Interrupt --
  68    ----------------------------
  69
  70    procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is
  71       pragma Warnings (Off, Interrupt);
  72    begin
  73       null;
  74    end Thread_Block_Interrupt;
  75
  76    ------------------------------
  77    -- Thread_Unblock_Interrupt --
  78    ------------------------------
  79
  80    procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is
  81       pragma Warnings (Off, Interrupt);
  82    begin
  83       null;
  84    end Thread_Unblock_Interrupt;
  85
  86    ------------------------
  87    -- Set_Interrupt_Mask --
  88    ------------------------
  89
  90    procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
  91       pragma Warnings (Off, Mask);
  92    begin
  93       null;
  94    end Set_Interrupt_Mask;
  95
  96    procedure Set_Interrupt_Mask
  97      (Mask  : access Interrupt_Mask;
  98       OMask : access Interrupt_Mask)
  99    is
 100       pragma Warnings (Off, Mask);
 101       pragma Warnings (Off, OMask);
 102    begin
 103       null;
 104    end Set_Interrupt_Mask;
 105
 106    ------------------------
 107    -- Get_Interrupt_Mask --
 108    ------------------------
 109
 110    procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
 111       pragma Warnings (Off, Mask);
 112    begin
 113       null;
 114    end Get_Interrupt_Mask;
 115
 116    --------------------
 117    -- Interrupt_Wait --
 118    --------------------
 119
 120    function To_unsigned_long is new
 121      Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, unsigned_long);
 122
 123    function Interrupt_Wait (Mask : access Interrupt_Mask)
 124      return Interrupt_ID
 125    is
 126       Self_ID : constant Task_Id := Self;
 127       Iosb    : IO_Status_Block_Type := (0, 0, 0);
 128       Status  : Cond_Value_Type;
 129
 130    begin
 131
 132       --  A QIO read is registered. The system call returns immediately
 133       --  after scheduling an AST to be fired when the operation
 134       --  completes.
 135
 136       Sys_QIO
 137         (Status => Status,
 138          Chan   => Rcv_Interrupt_Chan,
 139          Func   => IO_READVBLK,
 140          Iosb   => Iosb,
 141          Astadr =>
 142            POP.DEC.Interrupt_AST_Handler'Access,
 143          Astprm => To_Address (Self_ID),
 144          P1     => To_unsigned_long (Interrupt_Mailbox'Address),
 145          P2     => Interrupt_ID'Size / 8);
 146
 147       pragma Assert ((Status and 1) = 1);
 148
 149       loop
 150
 151          --  Wait to be woken up. Could be that the AST has fired,
 152          --  in which case the Iosb.Status variable will be non-zero,
 153          --  or maybe the wait is being aborted.
 154
 155          POP.Sleep
 156            (Self_ID,
 157             System.Tasking.Interrupt_Server_Blocked_On_Event_Flag);
 158
 159          if Iosb.Status /= 0 then
 160             if (Iosb.Status and 1) = 1
 161               and then Mask (Signal (Interrupt_Mailbox))
 162             then
 163                return Interrupt_Mailbox;
 164             else
 165                return 0;
 166             end if;
 167          else
 168             POP.Unlock (Self_ID);
 169
 170             if Single_Lock then
 171                POP.Unlock_RTS;
 172             end if;
 173
 174             System.Tasking.Initialization.Undefer_Abort (Self_ID);
 175             System.Tasking.Initialization.Defer_Abort (Self_ID);
 176
 177             if Single_Lock then
 178                POP.Lock_RTS;
 179             end if;
 180
 181             POP.Write_Lock (Self_ID);
 182          end if;
 183       end loop;
 184    end Interrupt_Wait;
 185
 186    ----------------------------
 187    -- Install_Default_Action --
 188    ----------------------------
 189
 190    procedure Install_Default_Action (Interrupt : Interrupt_ID) is
 191       pragma Warnings (Off, Interrupt);
 192    begin
 193       null;
 194    end Install_Default_Action;
 195
 196    ---------------------------
 197    -- Install_Ignore_Action --
 198    ---------------------------
 199
 200    procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
 201       pragma Warnings (Off, Interrupt);
 202    begin
 203       null;
 204    end Install_Ignore_Action;
 205
 206    -------------------------
 207    -- Fill_Interrupt_Mask --
 208    -------------------------
 209
 210    procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
 211    begin
 212       Mask.all := (others => True);
 213    end Fill_Interrupt_Mask;
 214
 215    --------------------------
 216    -- Empty_Interrupt_Mask --
 217    --------------------------
 218
 219    procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
 220    begin
 221       Mask.all := (others => False);
 222    end Empty_Interrupt_Mask;
 223
 224    ---------------------------
 225    -- Add_To_Interrupt_Mask --
 226    ---------------------------
 227
 228    procedure Add_To_Interrupt_Mask
 229      (Mask      : access Interrupt_Mask;
 230       Interrupt : Interrupt_ID)
 231    is
 232    begin
 233       Mask (Signal (Interrupt)) := True;
 234    end Add_To_Interrupt_Mask;
 235
 236    --------------------------------
 237    -- Delete_From_Interrupt_Mask --
 238    --------------------------------
 239
 240    procedure Delete_From_Interrupt_Mask
 241      (Mask      : access Interrupt_Mask;
 242       Interrupt : Interrupt_ID)
 243    is
 244    begin
 245       Mask (Signal (Interrupt)) := False;
 246    end Delete_From_Interrupt_Mask;
 247
 248    ---------------
 249    -- Is_Member --
 250    ---------------
 251
 252    function Is_Member
 253      (Mask      : access Interrupt_Mask;
 254       Interrupt : Interrupt_ID) return Boolean
 255    is
 256    begin
 257       return Mask (Signal (Interrupt));
 258    end Is_Member;
 259
 260    -------------------------
 261    -- Copy_Interrupt_Mask --
 262    -------------------------
 263
 264    procedure Copy_Interrupt_Mask
 265      (X : out Interrupt_Mask;
 266       Y : Interrupt_Mask)
 267    is
 268    begin
 269       X := Y;
 270    end Copy_Interrupt_Mask;
 271
 272    ----------------------------
 273    -- Interrupt_Self_Process --
 274    ----------------------------
 275
 276    procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
 277       Status : Cond_Value_Type;
 278    begin
 279       Sys_QIO
 280         (Status => Status,
 281          Chan   => Snd_Interrupt_Chan,
 282          Func   => IO_WRITEVBLK,
 283          P1     => To_unsigned_long (Interrupt'Address),
 284          P2     => Interrupt_ID'Size / 8);
 285
 286       --  The following could use a comment ???
 287
 288       pragma Assert ((Status and 1) = 1);
 289    end Interrupt_Self_Process;
 290
 291    --------------------------
 292    -- Setup_Interrupt_Mask --
 293    --------------------------
 294
 295    procedure Setup_Interrupt_Mask is
 296    begin
 297       null;
 298    end Setup_Interrupt_Mask;
 299
 300 begin
 301    Interrupt_Management.Initialize;
 302    Environment_Mask := (others => False);
 303    All_Tasks_Mask := (others => True);
 304
 305    for J in Interrupt_ID loop
 306       if Keep_Unmasked (J) then
 307          Environment_Mask (Signal (J)) := True;
 308          All_Tasks_Mask (Signal (J)) := False;
 309       end if;
 310    end loop;
 311 end System.Interrupt_Management.Operations;