gcc/ada/s-tpoben.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --     S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S .    --
   6 --                               E N T R I E S                              --
   7 --                                                                          --
   8 --                                  B o d y                                 --
   9 --                                                                          --
  10 --                             $Revision: 1.11 $
  11 --                                                                          --
  12 --            Copyright (C) 1991-2001, 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 package contains all the simple primitives related to
  39 --  Protected_Objects with entries (i.e init, lock, unlock).
  40
  41 --  The handling of protected objects with no entries is done in
  42 --  System.Tasking.Protected_Objects, the complex routines for protected
  43 --  objects with entries in System.Tasking.Protected_Objects.Operations.
  44 --  The split between Entries and Operations is needed to break circular
  45 --  dependencies inside the run time.
  46
  47 --  Note: the compiler generates direct calls to this interface, via Rtsfind.
  48
  49 with Ada.Exceptions;
  50 --  used for Exception_Occurrence_Access
  51
  52 with System.Task_Primitives.Operations;
  53 --  used for Initialize_Lock
  54 --           Write_Lock
  55 --           Unlock
  56 --           Get_Priority
  57 --           Wakeup
  58
  59 with System.Tasking.Initialization;
  60 --  used for Defer_Abort,
  61 --           Undefer_Abort,
  62 --           Change_Base_Priority
  63
  64 pragma Elaborate_All (System.Tasking.Initialization);
  65 --  this insures that tasking is initialized if any protected objects are
  66 --  created.
  67
  68 package body System.Tasking.Protected_Objects.Entries is
  69
  70    package STPO renames System.Task_Primitives.Operations;
  71
  72    use Ada.Exceptions;
  73    use STPO;
  74
  75    Locking_Policy : Character;
  76    pragma Import (C, Locking_Policy, "__gl_locking_policy");
  77
  78    --------------
  79    -- Finalize --
  80    --------------
  81
  82    procedure Finalize (Object : in out Protection_Entries) is
  83       Entry_Call        : Entry_Call_Link;
  84       Caller            : Task_ID;
  85       Ceiling_Violation : Boolean;
  86       Self_ID           : constant Task_ID := STPO.Self;
  87       Old_Base_Priority : System.Any_Priority;
  88
  89    begin
  90       if Object.Finalized then
  91          return;
  92       end if;
  93
  94       STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
  95
  96       if Ceiling_Violation then
  97
  98          --  Dip our own priority down to ceiling of lock.
  99          --  See similar code in Tasking.Entry_Calls.Lock_Server.
 100
 101          STPO.Write_Lock (Self_ID);
 102          Old_Base_Priority := Self_ID.Common.Base_Priority;
 103          Self_ID.New_Base_Priority := Object.Ceiling;
 104          Initialization.Change_Base_Priority (Self_ID);
 105          STPO.Unlock (Self_ID);
 106          STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
 107
 108          if Ceiling_Violation then
 109             Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 110          end if;
 111
 112          Object.Old_Base_Priority := Old_Base_Priority;
 113          Object.Pending_Action := True;
 114       end if;
 115
 116       --  Send program_error to all tasks still queued on this object.
 117
 118       for E in Object.Entry_Queues'Range loop
 119          Entry_Call := Object.Entry_Queues (E).Head;
 120
 121          while Entry_Call /= null loop
 122             Caller := Entry_Call.Self;
 123             Entry_Call.Exception_To_Raise := Program_Error'Identity;
 124             STPO.Write_Lock (Caller);
 125             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 126             STPO.Unlock (Caller);
 127             exit when Entry_Call = Object.Entry_Queues (E).Tail;
 128             Entry_Call := Entry_Call.Next;
 129          end loop;
 130       end loop;
 131
 132       Object.Finalized := True;
 133       STPO.Unlock (Object.L'Unrestricted_Access);
 134       STPO.Finalize_Lock (Object.L'Unrestricted_Access);
 135    end Finalize;
 136
 137    -------------------------------------
 138    -- Has_Interrupt_Or_Attach_Handler --
 139    -------------------------------------
 140
 141    function Has_Interrupt_Or_Attach_Handler
 142      (Object : Protection_Entries_Access)
 143       return   Boolean
 144    is
 145    begin
 146       return False;
 147    end Has_Interrupt_Or_Attach_Handler;
 148
 149    -----------------------------------
 150    -- Initialize_Protection_Entries --
 151    -----------------------------------
 152
 153    procedure Initialize_Protection_Entries
 154      (Object            : Protection_Entries_Access;
 155       Ceiling_Priority  : Integer;
 156       Compiler_Info     : System.Address;
 157       Entry_Bodies      : Protected_Entry_Body_Access;
 158       Find_Body_Index   : Find_Body_Index_Access)
 159    is
 160       Init_Priority : Integer := Ceiling_Priority;
 161       Self_ID       : constant Task_ID := STPO.Self;
 162
 163    begin
 164       if Init_Priority = Unspecified_Priority then
 165          Init_Priority  := System.Priority'Last;
 166       end if;
 167
 168       if Locking_Policy = 'C'
 169         and then Has_Interrupt_Or_Attach_Handler (Object)
 170         and then Init_Priority not in System.Interrupt_Priority
 171       then
 172          --  Required by C.3.1(11)
 173
 174          raise Program_Error;
 175       end if;
 176
 177       Initialization.Defer_Abort (Self_ID);
 178       Initialize_Lock (Init_Priority, Object.L'Access);
 179       Initialization.Undefer_Abort (Self_ID);
 180       Object.Ceiling := System.Any_Priority (Init_Priority);
 181       Object.Compiler_Info := Compiler_Info;
 182       Object.Pending_Action := False;
 183       Object.Call_In_Progress := null;
 184       Object.Entry_Bodies := Entry_Bodies;
 185       Object.Find_Body_Index :=  Find_Body_Index;
 186
 187       for E in Object.Entry_Queues'Range loop
 188          Object.Entry_Queues (E).Head := null;
 189          Object.Entry_Queues (E).Tail := null;
 190       end loop;
 191    end Initialize_Protection_Entries;
 192
 193    ------------------
 194    -- Lock_Entries --
 195    ------------------
 196
 197    procedure Lock_Entries
 198      (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is
 199    begin
 200       --  The lock is made without defering abortion.
 201
 202       --  Therefore the abortion has to be deferred before calling this
 203       --  routine. This means that the compiler has to generate a Defer_Abort
 204       --  call before the call to Lock.
 205
 206       --  The caller is responsible for undeferring abortion, and compiler
 207       --  generated calls must be protected with cleanup handlers to ensure
 208       --  that abortion is undeferred in all cases.
 209
 210       pragma Assert (STPO.Self.Deferral_Level > 0);
 211       Write_Lock (Object.L'Access, Ceiling_Violation);
 212    end Lock_Entries;
 213
 214    procedure Lock_Entries (Object : Protection_Entries_Access) is
 215       Ceiling_Violation : Boolean;
 216    begin
 217       pragma Assert (STPO.Self.Deferral_Level > 0);
 218       Write_Lock (Object.L'Access, Ceiling_Violation);
 219
 220       if Ceiling_Violation then
 221          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 222       end if;
 223    end Lock_Entries;
 224
 225    ----------------------------
 226    -- Lock_Read_Only_Entries --
 227    ----------------------------
 228
 229    procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
 230       Ceiling_Violation : Boolean;
 231    begin
 232       Read_Lock (Object.L'Access, Ceiling_Violation);
 233
 234       if Ceiling_Violation then
 235          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 236       end if;
 237    end Lock_Read_Only_Entries;
 238
 239    --------------------
 240    -- Unlock_Entries --
 241    --------------------
 242
 243    procedure Unlock_Entries (Object : Protection_Entries_Access) is
 244    begin
 245       Unlock (Object.L'Access);
 246    end Unlock_Entries;
 247
 248 end System.Tasking.Protected_Objects.Entries;