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