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.Owner := Null_Task;
 210       Object.Compiler_Info := Compiler_Info;
 211       Object.Pending_Action := False;
 212       Object.Call_In_Progress := null;
 213       Object.Entry_Bodies := Entry_Bodies;
 214       Object.Find_Body_Index :=  Find_Body_Index;
 215
 216       for E in Object.Entry_Queues'Range loop
 217          Object.Entry_Queues (E).Head := null;
 218          Object.Entry_Queues (E).Tail := null;
 219       end loop;
 220    end Initialize_Protection_Entries;
 221
 222    ------------------
 223    -- Lock_Entries --
 224    ------------------
 225
 226    procedure Lock_Entries
 227      (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean)
 228    is
 229    begin
 230       if Object.Finalized then
 231          Raise_Exception
 232            (Program_Error'Identity, "Protected Object is finalized");
 233       end if;
 234
 235       --  If pragma Detect_Blocking is active then, as described in the ARM
 236       --  9.5.1, par. 15, we must check whether this is an external call on a
 237       --  protected subprogram with the same target object as that of the
 238       --  protected action that is currently in progress (i.e., if the caller
 239       --  is already the protected object's owner). If this is the case hence
 240       --  Program_Error must be raised.
 241
 242       if Detect_Blocking and then Object.Owner = Self then
 243          raise Program_Error;
 244       end if;
 245
 246       --  The lock is made without defering abort
 247
 248       --  Therefore the abort has to be deferred before calling this routine.
 249       --  This means that the compiler has to generate a Defer_Abort call
 250       --  before the call to Lock.
 251
 252       --  The caller is responsible for undeferring abort, and compiler
 253       --  generated calls must be protected with cleanup handlers to ensure
 254       --  that abort is undeferred in all cases.
 255
 256       pragma Assert (STPO.Self.Deferral_Level > 0);
 257       Write_Lock (Object.L'Access, Ceiling_Violation);
 258
 259       --  We are entering in a protected action, so that we increase the
 260       --  protected object nesting level (if pragma Detect_Blocking is
 261       --  active), and update the protected object's owner.
 262
 263       if Detect_Blocking then
 264          declare
 265             Self_Id : constant Task_Id := Self;
 266
 267          begin
 268             --  Update the protected object's owner
 269
 270             Object.Owner := Self_Id;
 271
 272             --  Increase protected object nesting level
 273
 274             Self_Id.Common.Protected_Action_Nesting :=
 275               Self_Id.Common.Protected_Action_Nesting + 1;
 276          end;
 277       end if;
 278
 279    end Lock_Entries;
 280
 281    procedure Lock_Entries (Object : Protection_Entries_Access) is
 282       Ceiling_Violation : Boolean;
 283
 284    begin
 285       Lock_Entries (Object, Ceiling_Violation);
 286
 287       if Ceiling_Violation then
 288          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 289       end if;
 290    end Lock_Entries;
 291
 292    ----------------------------
 293    -- Lock_Read_Only_Entries --
 294    ----------------------------
 295
 296    procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
 297       Ceiling_Violation : Boolean;
 298
 299    begin
 300       if Object.Finalized then
 301          Raise_Exception
 302            (Program_Error'Identity, "Protected Object is finalized");
 303       end if;
 304
 305       --  If pragma Detect_Blocking is active then, as described in the ARM
 306       --  9.5.1, par. 15, we must check whether this is an external call on a
 307       --  protected subprogram with the same target object as that of the
 308       --  protected action that is currently in progress (i.e., if the caller
 309       --  is already the protected object's owner). If this is the case hence
 310       --  Program_Error must be raised.
 311
 312       --  Note that in this case (getting read access), several tasks may
 313       --  have read ownership of the protected object, so that this method of
 314       --  storing the (single) protected object's owner does not work
 315       --  reliably for read locks. However, this is the approach taken for two
 316       --  major reasosn: first, this function is not currently being used (it
 317       --  is provided for possible future use), and second, it largely
 318       --  simplifies the implementation.
 319
 320       if Detect_Blocking and then Object.Owner = Self then
 321          raise Program_Error;
 322       end if;
 323
 324       Read_Lock (Object.L'Access, Ceiling_Violation);
 325
 326       if Ceiling_Violation then
 327          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 328       end if;
 329
 330       --  We are entering in a protected action, so that we increase the
 331       --  protected object nesting level (if pragma Detect_Blocking is
 332       --  active), and update the protected object's owner.
 333
 334       if Detect_Blocking then
 335          declare
 336             Self_Id : constant Task_Id := Self;
 337
 338          begin
 339             --  Update the protected object's owner
 340
 341             Object.Owner := Self_Id;
 342
 343             --  Increase protected object nesting level
 344
 345             Self_Id.Common.Protected_Action_Nesting :=
 346               Self_Id.Common.Protected_Action_Nesting + 1;
 347          end;
 348       end if;
 349    end Lock_Read_Only_Entries;
 350
 351    --------------------
 352    -- Unlock_Entries --
 353    --------------------
 354
 355    procedure Unlock_Entries (Object : Protection_Entries_Access) is
 356    begin
 357       --  We are exiting from a protected action, so that we decrease the
 358       --  protected object nesting level (if pragma Detect_Blocking is
 359       --  active), and remove ownership of the protected object.
 360
 361       if Detect_Blocking then
 362          declare
 363             Self_Id : constant Task_Id := Self;
 364
 365          begin
 366             --  Calls to this procedure can only take place when being within
 367             --  a protected action and when the caller is the protected
 368             --  object's owner.
 369
 370             pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
 371                              and then Object.Owner = Self_Id);
 372
 373             --  Remove ownership of the protected object
 374
 375             Object.Owner := Null_Task;
 376
 377             Self_Id.Common.Protected_Action_Nesting :=
 378               Self_Id.Common.Protected_Action_Nesting - 1;
 379          end;
 380       end if;
 381
 382       Unlock (Object.L'Access);
 383    end Unlock_Entries;
 384
 385 end System.Tasking.Protected_Objects.Entries;