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-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,  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 protected
  35 --  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
  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 --           Raise_Exception
  49
  50 with System.Task_Primitives.Operations;
  51 --  Used for Initialize_Lock
  52 --           Write_Lock
  53 --           Unlock
  54 --           Get_Priority
  55 --           Wakeup
  56
  57 with System.Tasking.Initialization;
  58 --  Used for Defer_Abort,
  59 --           Undefer_Abort,
  60 --           Change_Base_Priority
  61
  62 pragma Elaborate_All (System.Tasking.Initialization);
  63 --  This insures that tasking is initialized if any protected objects are
  64 --  created.
  65
  66 with System.Parameters;
  67 --  Used for Single_Lock
  68
  69 package body System.Tasking.Protected_Objects.Entries is
  70
  71    package STPO renames System.Task_Primitives.Operations;
  72
  73    use Parameters;
  74    use Task_Primitives.Operations;
  75    use Ada.Exceptions;
  76
  77    ----------------
  78    -- Local Data --
  79    ----------------
  80
  81    Locking_Policy : Character;
  82    pragma Import (C, Locking_Policy, "__gl_locking_policy");
  83
  84    --------------
  85    -- Finalize --
  86    --------------
  87
  88    procedure Finalize (Object : in out Protection_Entries) is
  89       Entry_Call        : Entry_Call_Link;
  90       Caller            : Task_Id;
  91       Ceiling_Violation : Boolean;
  92       Self_ID           : constant Task_Id := STPO.Self;
  93       Old_Base_Priority : System.Any_Priority;
  94
  95    begin
  96       if Object.Finalized then
  97          return;
  98       end if;
  99
 100       STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
 101
 102       if Single_Lock then
 103          Lock_RTS;
 104       end if;
 105
 106       if Ceiling_Violation then
 107
 108          --  Dip our own priority down to ceiling of lock. See similar code in
 109          --  Tasking.Entry_Calls.Lock_Server.
 110
 111          STPO.Write_Lock (Self_ID);
 112          Old_Base_Priority := Self_ID.Common.Base_Priority;
 113          Self_ID.New_Base_Priority := Object.Ceiling;
 114          Initialization.Change_Base_Priority (Self_ID);
 115          STPO.Unlock (Self_ID);
 116
 117          if Single_Lock then
 118             Unlock_RTS;
 119          end if;
 120
 121          STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
 122
 123          if Ceiling_Violation then
 124             Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 125          end if;
 126
 127          if Single_Lock then
 128             Lock_RTS;
 129          end if;
 130
 131          Object.Old_Base_Priority := Old_Base_Priority;
 132          Object.Pending_Action := True;
 133       end if;
 134
 135       --  Send program_error to all tasks still queued on this object
 136
 137       for E in Object.Entry_Queues'Range loop
 138          Entry_Call := Object.Entry_Queues (E).Head;
 139
 140          while Entry_Call /= null loop
 141             Caller := Entry_Call.Self;
 142             Entry_Call.Exception_To_Raise := Program_Error'Identity;
 143
 144             STPO.Write_Lock (Caller);
 145             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 146             STPO.Unlock (Caller);
 147
 148             exit when Entry_Call = Object.Entry_Queues (E).Tail;
 149             Entry_Call := Entry_Call.Next;
 150          end loop;
 151       end loop;
 152
 153       Object.Finalized := True;
 154
 155       if Single_Lock then
 156          Unlock_RTS;
 157       end if;
 158
 159       STPO.Unlock (Object.L'Unrestricted_Access);
 160
 161       STPO.Finalize_Lock (Object.L'Unrestricted_Access);
 162    end Finalize;
 163
 164    -------------------------------------
 165    -- Has_Interrupt_Or_Attach_Handler --
 166    -------------------------------------
 167
 168    function Has_Interrupt_Or_Attach_Handler
 169      (Object : Protection_Entries_Access)
 170       return   Boolean
 171    is
 172       pragma Warnings (Off, Object);
 173    begin
 174       return False;
 175    end Has_Interrupt_Or_Attach_Handler;
 176
 177    -----------------------------------
 178    -- Initialize_Protection_Entries --
 179    -----------------------------------
 180
 181    procedure Initialize_Protection_Entries
 182      (Object            : Protection_Entries_Access;
 183       Ceiling_Priority  : Integer;
 184       Compiler_Info     : System.Address;
 185       Entry_Bodies      : Protected_Entry_Body_Access;
 186       Find_Body_Index   : Find_Body_Index_Access)
 187    is
 188       Init_Priority : Integer := Ceiling_Priority;
 189       Self_ID       : constant Task_Id := STPO.Self;
 190
 191    begin
 192       if Init_Priority = Unspecified_Priority then
 193          Init_Priority  := System.Priority'Last;
 194       end if;
 195
 196       if Locking_Policy = 'C'
 197         and then Has_Interrupt_Or_Attach_Handler (Object)
 198         and then Init_Priority not in System.Interrupt_Priority
 199       then
 200          --  Required by C.3.1(11)
 201
 202          raise Program_Error;
 203       end if;
 204
 205       Initialization.Defer_Abort (Self_ID);
 206       Initialize_Lock (Init_Priority, Object.L'Access);
 207       Initialization.Undefer_Abort (Self_ID);
 208       Object.Ceiling := System.Any_Priority (Init_Priority);
 209       Object.Compiler_Info := Compiler_Info;
 210       Object.Pending_Action := False;
 211       Object.Call_In_Progress := null;
 212       Object.Entry_Bodies := Entry_Bodies;
 213       Object.Find_Body_Index :=  Find_Body_Index;
 214
 215       for E in Object.Entry_Queues'Range loop
 216          Object.Entry_Queues (E).Head := null;
 217          Object.Entry_Queues (E).Tail := null;
 218       end loop;
 219    end Initialize_Protection_Entries;
 220
 221    ------------------
 222    -- Lock_Entries --
 223    ------------------
 224
 225    procedure Lock_Entries
 226      (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean)
 227    is
 228    begin
 229       if Object.Finalized then
 230          Raise_Exception
 231            (Program_Error'Identity, "Protected Object is finalized");
 232       end if;
 233
 234       --  If pragma Detect_Blocking is active then Program_Error must be
 235       --  raised if this potentially blocking operation is called from a
 236       --  protected action, and the protected object nesting level must be
 237       --  increased.
 238
 239       if Detect_Blocking then
 240          declare
 241             Self_Id : constant Task_Id := STPO.Self;
 242          begin
 243             if Self_Id.Common.Protected_Action_Nesting > 0  then
 244                Ada.Exceptions.Raise_Exception
 245                  (Program_Error'Identity, "potentially blocking operation");
 246             else
 247                --  We are entering in a protected action, so that we increase
 248                --  the protected object nesting level.
 249
 250                Self_Id.Common.Protected_Action_Nesting :=
 251                  Self_Id.Common.Protected_Action_Nesting + 1;
 252             end if;
 253          end;
 254       end if;
 255
 256       --  The lock is made without defering abort
 257
 258       --  Therefore the abort has to be deferred before calling this routine.
 259       --  This means that the compiler has to generate a Defer_Abort call
 260       --  before the call to Lock.
 261
 262       --  The caller is responsible for undeferring abort, and compiler
 263       --  generated calls must be protected with cleanup handlers to ensure
 264       --  that abort is undeferred in all cases.
 265
 266       pragma Assert (STPO.Self.Deferral_Level > 0);
 267       Write_Lock (Object.L'Access, Ceiling_Violation);
 268    end Lock_Entries;
 269
 270    procedure Lock_Entries (Object : Protection_Entries_Access) is
 271       Ceiling_Violation : Boolean;
 272
 273    begin
 274       Lock_Entries (Object, Ceiling_Violation);
 275
 276       if Ceiling_Violation then
 277          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 278       end if;
 279    end Lock_Entries;
 280
 281    ----------------------------
 282    -- Lock_Read_Only_Entries --
 283    ----------------------------
 284
 285    procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
 286       Ceiling_Violation : Boolean;
 287
 288    begin
 289       if Object.Finalized then
 290          Raise_Exception
 291            (Program_Error'Identity, "Protected Object is finalized");
 292       end if;
 293
 294       --  If pragma Detect_Blocking is active then Program_Error must be
 295       --  raised if this potentially blocking operation is called from a
 296       --  protected action, and the protected object nesting level must
 297       --  be increased.
 298
 299       if Detect_Blocking then
 300          declare
 301             Self_Id : constant Task_Id := STPO.Self;
 302          begin
 303             if Self_Id.Common.Protected_Action_Nesting > 0  then
 304                Ada.Exceptions.Raise_Exception
 305                  (Program_Error'Identity, "potentially blocking operation");
 306             else
 307                --  We are entering in a protected action, so that we increase
 308                --  the protected object nesting level.
 309
 310                Self_Id.Common.Protected_Action_Nesting :=
 311                  Self_Id.Common.Protected_Action_Nesting + 1;
 312             end if;
 313          end;
 314       end if;
 315
 316       Read_Lock (Object.L'Access, Ceiling_Violation);
 317
 318       if Ceiling_Violation then
 319          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 320       end if;
 321    end Lock_Read_Only_Entries;
 322
 323    --------------------
 324    -- Unlock_Entries --
 325    --------------------
 326
 327    procedure Unlock_Entries (Object : Protection_Entries_Access) is
 328    begin
 329       --  We are exiting from a protected action, so that we decrease the
 330       --  protected object nesting level (if pragma Detect_Blocking is
 331       --  active).
 332
 333       if Detect_Blocking then
 334          declare
 335             Self_Id : constant Task_Id := Self;
 336          begin
 337             --  Cannot call this procedure without being within a protected
 338             --  action.
 339
 340             pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0);
 341
 342             Self_Id.Common.Protected_Action_Nesting :=
 343               Self_Id.Common.Protected_Action_Nesting - 1;
 344          end;
 345       end if;
 346
 347       Unlock (Object.L'Access);
 348    end Unlock_Entries;
 349
 350 end System.Tasking.Protected_Objects.Entries;