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-2008, 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 with System.Aux_DEC;
  38 with System.Parameters;
  39 with System.Tasking;
  40 with System.Tasking.Initialization;
  41 with System.Task_Primitives.Operations;
  42 with System.Task_Primitives.Operations.DEC;
  43
  44 with Ada.Unchecked_Conversion;
  45
  46 package body System.Interrupt_Management.Operations is
  47
  48    use System.OS_Interface;
  49    use System.Parameters;
  50    use System.Tasking;
  51    use type unsigned_short;
  52
  53    function To_Address is
  54      new Ada.Unchecked_Conversion (Task_Id, System.Address);
  55
  56    package POP renames System.Task_Primitives.Operations;
  57
  58    ----------------------------
  59    -- Thread_Block_Interrupt --
  60    ----------------------------
  61
  62    procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is
  63       pragma Warnings (Off, Interrupt);
  64    begin
  65       null;
  66    end Thread_Block_Interrupt;
  67
  68    ------------------------------
  69    -- Thread_Unblock_Interrupt --
  70    ------------------------------
  71
  72    procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is
  73       pragma Warnings (Off, Interrupt);
  74    begin
  75       null;
  76    end Thread_Unblock_Interrupt;
  77
  78    ------------------------
  79    -- Set_Interrupt_Mask --
  80    ------------------------
  81
  82    procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
  83       pragma Warnings (Off, Mask);
  84    begin
  85       null;
  86    end Set_Interrupt_Mask;
  87
  88    procedure Set_Interrupt_Mask
  89      (Mask  : access Interrupt_Mask;
  90       OMask : access Interrupt_Mask)
  91    is
  92       pragma Warnings (Off, Mask);
  93       pragma Warnings (Off, OMask);
  94    begin
  95       null;
  96    end Set_Interrupt_Mask;
  97
  98    ------------------------
  99    -- Get_Interrupt_Mask --
 100    ------------------------
 101
 102    procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
 103       pragma Warnings (Off, Mask);
 104    begin
 105       null;
 106    end Get_Interrupt_Mask;
 107
 108    --------------------
 109    -- Interrupt_Wait --
 110    --------------------
 111
 112    function To_unsigned_long is new
 113      Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, unsigned_long);
 114
 115    function Interrupt_Wait (Mask : access Interrupt_Mask)
 116      return Interrupt_ID
 117    is
 118       Self_ID : constant Task_Id := Self;
 119       Iosb    : IO_Status_Block_Type := (0, 0, 0);
 120       Status  : Cond_Value_Type;
 121
 122    begin
 123
 124       --  A QIO read is registered. The system call returns immediately
 125       --  after scheduling an AST to be fired when the operation
 126       --  completes.
 127
 128       Sys_QIO
 129         (Status => Status,
 130          Chan   => Rcv_Interrupt_Chan,
 131          Func   => IO_READVBLK,
 132          Iosb   => Iosb,
 133          Astadr =>
 134            POP.DEC.Interrupt_AST_Handler'Access,
 135          Astprm => To_Address (Self_ID),
 136          P1     => To_unsigned_long (Interrupt_Mailbox'Address),
 137          P2     => Interrupt_ID'Size / 8);
 138
 139       pragma Assert ((Status and 1) = 1);
 140
 141       loop
 142
 143          --  Wait to be woken up. Could be that the AST has fired,
 144          --  in which case the Iosb.Status variable will be non-zero,
 145          --  or maybe the wait is being aborted.
 146
 147          POP.Sleep
 148            (Self_ID,
 149             System.Tasking.Interrupt_Server_Blocked_On_Event_Flag);
 150
 151          if Iosb.Status /= 0 then
 152             if (Iosb.Status and 1) = 1
 153               and then Mask (Signal (Interrupt_Mailbox))
 154             then
 155                return Interrupt_Mailbox;
 156             else
 157                return 0;
 158             end if;
 159          else
 160             POP.Unlock (Self_ID);
 161
 162             if Single_Lock then
 163                POP.Unlock_RTS;
 164             end if;
 165
 166             System.Tasking.Initialization.Undefer_Abort (Self_ID);
 167             System.Tasking.Initialization.Defer_Abort (Self_ID);
 168
 169             if Single_Lock then
 170                POP.Lock_RTS;
 171             end if;
 172
 173             POP.Write_Lock (Self_ID);
 174          end if;
 175       end loop;
 176    end Interrupt_Wait;
 177
 178    ----------------------------
 179    -- Install_Default_Action --
 180    ----------------------------
 181
 182    procedure Install_Default_Action (Interrupt : Interrupt_ID) is
 183       pragma Warnings (Off, Interrupt);
 184    begin
 185       null;
 186    end Install_Default_Action;
 187
 188    ---------------------------
 189    -- Install_Ignore_Action --
 190    ---------------------------
 191
 192    procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
 193       pragma Warnings (Off, Interrupt);
 194    begin
 195       null;
 196    end Install_Ignore_Action;
 197
 198    -------------------------
 199    -- Fill_Interrupt_Mask --
 200    -------------------------
 201
 202    procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
 203    begin
 204       Mask.all := (others => True);
 205    end Fill_Interrupt_Mask;
 206
 207    --------------------------
 208    -- Empty_Interrupt_Mask --
 209    --------------------------
 210
 211    procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
 212    begin
 213       Mask.all := (others => False);
 214    end Empty_Interrupt_Mask;
 215
 216    ---------------------------
 217    -- Add_To_Interrupt_Mask --
 218    ---------------------------
 219
 220    procedure Add_To_Interrupt_Mask
 221      (Mask      : access Interrupt_Mask;
 222       Interrupt : Interrupt_ID)
 223    is
 224    begin
 225       Mask (Signal (Interrupt)) := True;
 226    end Add_To_Interrupt_Mask;
 227
 228    --------------------------------
 229    -- Delete_From_Interrupt_Mask --
 230    --------------------------------
 231
 232    procedure Delete_From_Interrupt_Mask
 233      (Mask      : access Interrupt_Mask;
 234       Interrupt : Interrupt_ID)
 235    is
 236    begin
 237       Mask (Signal (Interrupt)) := False;
 238    end Delete_From_Interrupt_Mask;
 239
 240    ---------------
 241    -- Is_Member --
 242    ---------------
 243
 244    function Is_Member
 245      (Mask      : access Interrupt_Mask;
 246       Interrupt : Interrupt_ID) return Boolean
 247    is
 248    begin
 249       return Mask (Signal (Interrupt));
 250    end Is_Member;
 251
 252    -------------------------
 253    -- Copy_Interrupt_Mask --
 254    -------------------------
 255
 256    procedure Copy_Interrupt_Mask
 257      (X : out Interrupt_Mask;
 258       Y : Interrupt_Mask)
 259    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       Status : Cond_Value_Type;
 270    begin
 271       Sys_QIO
 272         (Status => Status,
 273          Chan   => Snd_Interrupt_Chan,
 274          Func   => IO_WRITEVBLK,
 275          P1     => To_unsigned_long (Interrupt'Address),
 276          P2     => Interrupt_ID'Size / 8);
 277
 278       --  The following could use a comment ???
 279
 280       pragma Assert ((Status and 1) = 1);
 281    end Interrupt_Self_Process;
 282
 283    --------------------------
 284    -- Setup_Interrupt_Mask --
 285    --------------------------
 286
 287    procedure Setup_Interrupt_Mask is
 288    begin
 289       null;
 290    end Setup_Interrupt_Mask;
 291
 292 begin
 293    Interrupt_Management.Initialize;
 294    Environment_Mask := (others => False);
 295    All_Tasks_Mask := (others => True);
 296
 297    for J in Interrupt_ID loop
 298       if Keep_Unmasked (J) then
 299          Environment_Mask (Signal (J)) := True;
 300          All_Tasks_Mask (Signal (J)) := False;
 301       end if;
 302    end loop;
 303 end System.Interrupt_Management.Operations;