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 --                                                                          --
  10 --         Copyright (C) 1998-2001, Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNARL was developed by the GNARL team at Florida State University. It is --
  31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com).     --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This package contains all the simple primitives related to
  36 --  Protected_Objects with entries (i.e init, lock, unlock).
  37
  38 --  The handling of protected objects with no entries is done in
  39 --  System.Tasking.Protected_Objects, the complex routines for protected
  40 --  objects with entries in System.Tasking.Protected_Objects.Operations.
  41 --  The split between Entries and Operations is needed to break circular
  42 --  dependencies inside the run time.
  43
  44 --  Note: the compiler generates direct calls to this interface, via Rtsfind.
  45
  46 with Ada.Exceptions;
  47 --  used for Exception_Occurrence_Access
  48
  49 with System.Task_Primitives.Operations;
  50 --  used for Initialize_Lock
  51 --           Write_Lock
  52 --           Unlock
  53 --           Get_Priority
  54 --           Wakeup
  55
  56 with System.Tasking.Initialization;
  57 --  used for Defer_Abort,
  58 --           Undefer_Abort,
  59 --           Change_Base_Priority
  60
  61 pragma Elaborate_All (System.Tasking.Initialization);
  62 --  this insures that tasking is initialized if any protected objects are
  63 --  created.
  64
  65 with System.Parameters;
  66 --  used for Single_Lock
  67
  68 package body System.Tasking.Protected_Objects.Entries is
  69
  70    package STPO renames System.Task_Primitives.Operations;
  71
  72    use Parameters;
  73    use Task_Primitives.Operations;
  74    use Ada.Exceptions;
  75
  76    Locking_Policy : Character;
  77    pragma Import (C, Locking_Policy, "__gl_locking_policy");
  78
  79    --------------
  80    -- Finalize --
  81    --------------
  82
  83    procedure Finalize (Object : in out Protection_Entries) is
  84       Entry_Call        : Entry_Call_Link;
  85       Caller            : Task_ID;
  86       Ceiling_Violation : Boolean;
  87       Self_ID           : constant Task_ID := STPO.Self;
  88       Old_Base_Priority : System.Any_Priority;
  89
  90    begin
  91       if Object.Finalized then
  92          return;
  93       end if;
  94
  95       STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
  96
  97       if Single_Lock then
  98          Lock_RTS;
  99       end if;
 100
 101       if Ceiling_Violation then
 102          --  Dip our own priority down to ceiling of lock.
 103          --  See similar code in Tasking.Entry_Calls.Lock_Server.
 104
 105          STPO.Write_Lock (Self_ID);
 106          Old_Base_Priority := Self_ID.Common.Base_Priority;
 107          Self_ID.New_Base_Priority := Object.Ceiling;
 108          Initialization.Change_Base_Priority (Self_ID);
 109          STPO.Unlock (Self_ID);
 110
 111          if Single_Lock then
 112             Unlock_RTS;
 113          end if;
 114
 115          STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
 116
 117          if Ceiling_Violation then
 118             Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 119          end if;
 120
 121          if Single_Lock then
 122             Lock_RTS;
 123          end if;
 124
 125          Object.Old_Base_Priority := Old_Base_Priority;
 126          Object.Pending_Action := True;
 127       end if;
 128
 129       --  Send program_error to all tasks still queued on this object.
 130
 131       for E in Object.Entry_Queues'Range loop
 132          Entry_Call := Object.Entry_Queues (E).Head;
 133
 134          while Entry_Call /= null loop
 135             Caller := Entry_Call.Self;
 136             Entry_Call.Exception_To_Raise := Program_Error'Identity;
 137
 138             STPO.Write_Lock (Caller);
 139             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 140             STPO.Unlock (Caller);
 141
 142             exit when Entry_Call = Object.Entry_Queues (E).Tail;
 143             Entry_Call := Entry_Call.Next;
 144          end loop;
 145       end loop;
 146
 147       Object.Finalized := True;
 148
 149       if Single_Lock then
 150          Unlock_RTS;
 151       end if;
 152
 153       STPO.Unlock (Object.L'Unrestricted_Access);
 154
 155       STPO.Finalize_Lock (Object.L'Unrestricted_Access);
 156    end Finalize;
 157
 158    -------------------------------------
 159    -- Has_Interrupt_Or_Attach_Handler --
 160    -------------------------------------
 161
 162    function Has_Interrupt_Or_Attach_Handler
 163      (Object : Protection_Entries_Access)
 164       return   Boolean
 165    is
 166       pragma Warnings (Off, Object);
 167    begin
 168       return False;
 169    end Has_Interrupt_Or_Attach_Handler;
 170
 171    -----------------------------------
 172    -- Initialize_Protection_Entries --
 173    -----------------------------------
 174
 175    procedure Initialize_Protection_Entries
 176      (Object            : Protection_Entries_Access;
 177       Ceiling_Priority  : Integer;
 178       Compiler_Info     : System.Address;
 179       Entry_Bodies      : Protected_Entry_Body_Access;
 180       Find_Body_Index   : Find_Body_Index_Access)
 181    is
 182       Init_Priority : Integer := Ceiling_Priority;
 183       Self_ID       : constant Task_ID := STPO.Self;
 184
 185    begin
 186       if Init_Priority = Unspecified_Priority then
 187          Init_Priority  := System.Priority'Last;
 188       end if;
 189
 190       if Locking_Policy = 'C'
 191         and then Has_Interrupt_Or_Attach_Handler (Object)
 192         and then Init_Priority not in System.Interrupt_Priority
 193       then
 194          --  Required by C.3.1(11)
 195
 196          raise Program_Error;
 197       end if;
 198
 199       Initialization.Defer_Abort (Self_ID);
 200       Initialize_Lock (Init_Priority, Object.L'Access);
 201       Initialization.Undefer_Abort (Self_ID);
 202       Object.Ceiling := System.Any_Priority (Init_Priority);
 203       Object.Compiler_Info := Compiler_Info;
 204       Object.Pending_Action := False;
 205       Object.Call_In_Progress := null;
 206       Object.Entry_Bodies := Entry_Bodies;
 207       Object.Find_Body_Index :=  Find_Body_Index;
 208
 209       for E in Object.Entry_Queues'Range loop
 210          Object.Entry_Queues (E).Head := null;
 211          Object.Entry_Queues (E).Tail := null;
 212       end loop;
 213    end Initialize_Protection_Entries;
 214
 215    ------------------
 216    -- Lock_Entries --
 217    ------------------
 218
 219    procedure Lock_Entries
 220      (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is
 221    begin
 222       if Object.Finalized then
 223          Raise_Exception
 224            (Program_Error'Identity, "Protected Object is finalized");
 225       end if;
 226
 227       --  The lock is made without defering abortion.
 228
 229       --  Therefore the abortion has to be deferred before calling this
 230       --  routine. This means that the compiler has to generate a Defer_Abort
 231       --  call before the call to Lock.
 232
 233       --  The caller is responsible for undeferring abortion, and compiler
 234       --  generated calls must be protected with cleanup handlers to ensure
 235       --  that abortion is undeferred in all cases.
 236
 237       pragma Assert (STPO.Self.Deferral_Level > 0);
 238       Write_Lock (Object.L'Access, Ceiling_Violation);
 239    end Lock_Entries;
 240
 241    procedure Lock_Entries (Object : Protection_Entries_Access) is
 242       Ceiling_Violation : Boolean;
 243    begin
 244       if Object.Finalized then
 245          Raise_Exception
 246            (Program_Error'Identity, "Protected Object is finalized");
 247       end if;
 248
 249       pragma Assert (STPO.Self.Deferral_Level > 0);
 250       Write_Lock (Object.L'Access, Ceiling_Violation);
 251
 252       if Ceiling_Violation then
 253          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 254       end if;
 255    end Lock_Entries;
 256
 257    ----------------------------
 258    -- Lock_Read_Only_Entries --
 259    ----------------------------
 260
 261    procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
 262       Ceiling_Violation : Boolean;
 263    begin
 264       if Object.Finalized then
 265          Raise_Exception
 266            (Program_Error'Identity, "Protected Object is finalized");
 267       end if;
 268
 269       Read_Lock (Object.L'Access, Ceiling_Violation);
 270
 271       if Ceiling_Violation then
 272          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 273       end if;
 274    end Lock_Read_Only_Entries;
 275
 276    --------------------
 277    -- Unlock_Entries --
 278    --------------------
 279
 280    procedure Unlock_Entries (Object : Protection_Entries_Access) is
 281    begin
 282       Unlock (Object.L'Access);
 283    end Unlock_Entries;
 284
 285 end System.Tasking.Protected_Objects.Entries;