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