gcc/ada/s-tpoben.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --               GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS                --
   4 --                                                                          --
   5 --                 SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES                 --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1998-2004, 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 package contains all the simple primitives related to
  35 --  Protected_Objects with entries (i.e init, lock, unlock).
  36
  37 --  The handling of protected objects with no entries is done in
  38 --  System.Tasking.Protected_Objects, the complex routines for protected
  39 --  objects with entries in System.Tasking.Protected_Objects.Operations.
  40 --  The split between Entries and Operations is needed to break circular
  41 --  dependencies inside the run time.
  42
  43 --  Note: the compiler generates direct calls to this interface, via Rtsfind.
  44
  45 with Ada.Exceptions;
  46 --  used for Exception_Occurrence_Access
  47
  48 with System.Task_Primitives.Operations;
  49 --  used for Initialize_Lock
  50 --           Write_Lock
  51 --           Unlock
  52 --           Get_Priority
  53 --           Wakeup
  54
  55 with System.Tasking.Initialization;
  56 --  used for Defer_Abort,
  57 --           Undefer_Abort,
  58 --           Change_Base_Priority
  59
  60 pragma Elaborate_All (System.Tasking.Initialization);
  61 --  this insures that tasking is initialized if any protected objects are
  62 --  created.
  63
  64 with System.Parameters;
  65 --  used for Single_Lock
  66
  67 package body System.Tasking.Protected_Objects.Entries is
  68
  69    package STPO renames System.Task_Primitives.Operations;
  70
  71    use Parameters;
  72    use Task_Primitives.Operations;
  73    use Ada.Exceptions;
  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 Single_Lock then
  97          Lock_RTS;
  98       end if;
  99
 100       if Ceiling_Violation then
 101          --  Dip our own priority down to ceiling of lock.
 102          --  See similar code in Tasking.Entry_Calls.Lock_Server.
 103
 104          STPO.Write_Lock (Self_ID);
 105          Old_Base_Priority := Self_ID.Common.Base_Priority;
 106          Self_ID.New_Base_Priority := Object.Ceiling;
 107          Initialization.Change_Base_Priority (Self_ID);
 108          STPO.Unlock (Self_ID);
 109
 110          if Single_Lock then
 111             Unlock_RTS;
 112          end if;
 113
 114          STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
 115
 116          if Ceiling_Violation then
 117             Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 118          end if;
 119
 120          if Single_Lock then
 121             Lock_RTS;
 122          end if;
 123
 124          Object.Old_Base_Priority := Old_Base_Priority;
 125          Object.Pending_Action := True;
 126       end if;
 127
 128       --  Send program_error to all tasks still queued on this object.
 129
 130       for E in Object.Entry_Queues'Range loop
 131          Entry_Call := Object.Entry_Queues (E).Head;
 132
 133          while Entry_Call /= null loop
 134             Caller := Entry_Call.Self;
 135             Entry_Call.Exception_To_Raise := Program_Error'Identity;
 136
 137             STPO.Write_Lock (Caller);
 138             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 139             STPO.Unlock (Caller);
 140
 141             exit when Entry_Call = Object.Entry_Queues (E).Tail;
 142             Entry_Call := Entry_Call.Next;
 143          end loop;
 144       end loop;
 145
 146       Object.Finalized := True;
 147
 148       if Single_Lock then
 149          Unlock_RTS;
 150       end if;
 151
 152       STPO.Unlock (Object.L'Unrestricted_Access);
 153
 154       STPO.Finalize_Lock (Object.L'Unrestricted_Access);
 155    end Finalize;
 156
 157    -------------------------------------
 158    -- Has_Interrupt_Or_Attach_Handler --
 159    -------------------------------------
 160
 161    function Has_Interrupt_Or_Attach_Handler
 162      (Object : Protection_Entries_Access)
 163       return   Boolean
 164    is
 165       pragma Warnings (Off, Object);
 166    begin
 167       return False;
 168    end Has_Interrupt_Or_Attach_Handler;
 169
 170    -----------------------------------
 171    -- Initialize_Protection_Entries --
 172    -----------------------------------
 173
 174    procedure Initialize_Protection_Entries
 175      (Object            : Protection_Entries_Access;
 176       Ceiling_Priority  : Integer;
 177       Compiler_Info     : System.Address;
 178       Entry_Bodies      : Protected_Entry_Body_Access;
 179       Find_Body_Index   : Find_Body_Index_Access)
 180    is
 181       Init_Priority : Integer := Ceiling_Priority;
 182       Self_ID       : constant Task_Id := STPO.Self;
 183
 184    begin
 185       if Init_Priority = Unspecified_Priority then
 186          Init_Priority  := System.Priority'Last;
 187       end if;
 188
 189       if Locking_Policy = 'C'
 190         and then Has_Interrupt_Or_Attach_Handler (Object)
 191         and then Init_Priority not in System.Interrupt_Priority
 192       then
 193          --  Required by C.3.1(11)
 194
 195          raise Program_Error;
 196       end if;
 197
 198       Initialization.Defer_Abort (Self_ID);
 199       Initialize_Lock (Init_Priority, Object.L'Access);
 200       Initialization.Undefer_Abort (Self_ID);
 201       Object.Ceiling := System.Any_Priority (Init_Priority);
 202       Object.Compiler_Info := Compiler_Info;
 203       Object.Pending_Action := False;
 204       Object.Call_In_Progress := null;
 205       Object.Entry_Bodies := Entry_Bodies;
 206       Object.Find_Body_Index :=  Find_Body_Index;
 207
 208       for E in Object.Entry_Queues'Range loop
 209          Object.Entry_Queues (E).Head := null;
 210          Object.Entry_Queues (E).Tail := null;
 211       end loop;
 212    end Initialize_Protection_Entries;
 213
 214    ------------------
 215    -- Lock_Entries --
 216    ------------------
 217
 218    procedure Lock_Entries
 219      (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is
 220    begin
 221       if Object.Finalized then
 222          Raise_Exception
 223            (Program_Error'Identity, "Protected Object is finalized");
 224       end if;
 225
 226       --  The lock is made without defering abortion.
 227
 228       --  Therefore the abortion has to be deferred before calling this
 229       --  routine. This means that the compiler has to generate a Defer_Abort
 230       --  call before the call to Lock.
 231
 232       --  The caller is responsible for undeferring abortion, and compiler
 233       --  generated calls must be protected with cleanup handlers to ensure
 234       --  that abortion is undeferred in all cases.
 235
 236       pragma Assert (STPO.Self.Deferral_Level > 0);
 237       Write_Lock (Object.L'Access, Ceiling_Violation);
 238    end Lock_Entries;
 239
 240    procedure Lock_Entries (Object : Protection_Entries_Access) is
 241       Ceiling_Violation : Boolean;
 242    begin
 243       if Object.Finalized then
 244          Raise_Exception
 245            (Program_Error'Identity, "Protected Object is finalized");
 246       end if;
 247
 248       pragma Assert (STPO.Self.Deferral_Level > 0);
 249       Write_Lock (Object.L'Access, Ceiling_Violation);
 250
 251       if Ceiling_Violation then
 252          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 253       end if;
 254    end Lock_Entries;
 255
 256    ----------------------------
 257    -- Lock_Read_Only_Entries --
 258    ----------------------------
 259
 260    procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
 261       Ceiling_Violation : Boolean;
 262    begin
 263       if Object.Finalized then
 264          Raise_Exception
 265            (Program_Error'Identity, "Protected Object is finalized");
 266       end if;
 267
 268       Read_Lock (Object.L'Access, Ceiling_Violation);
 269
 270       if Ceiling_Violation then
 271          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 272       end if;
 273    end Lock_Read_Only_Entries;
 274
 275    --------------------
 276    -- Unlock_Entries --
 277    --------------------
 278
 279    procedure Unlock_Entries (Object : Protection_Entries_Access) is
 280    begin
 281       Unlock (Object.L'Access);
 282    end Unlock_Entries;
 283
 284 end System.Tasking.Protected_Objects.Entries;