gcc/ada/5vinmaop.adb

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