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