gcc/ada/s-tpoben.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                  --
   4 --                                                                          --
   5 --      S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S .   --
   6 --                               E N T R I E S                              --
   7 --                                                                          --
   8 --                                  B o d y                                 --
   9 --                                                                          --
  10 --         Copyright (C) 1998-2007, 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,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, 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.       --
  31 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This package contains all the simple primitives related to protected
  36 --  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
  42 --  The split between Entries and Operations is needed to break circular
  43 --  dependencies inside the run time.
  44
  45 --  Note: the compiler generates direct calls to this interface, via Rtsfind
  46
  47 with Ada.Exceptions;
  48 --  Used for Exception_Occurrence_Access
  49 --           Raise_Exception
  50
  51 with System.Task_Primitives.Operations;
  52 --  Used for Initialize_Lock
  53 --           Write_Lock
  54 --           Unlock
  55 --           Get_Priority
  56 --           Wakeup
  57 --           Set_Ceiling
  58
  59 with System.Tasking.Initialization;
  60 --  Used for Defer_Abort,
  61 --           Undefer_Abort,
  62 --           Change_Base_Priority
  63
  64 pragma Elaborate_All (System.Tasking.Initialization);
  65 --  This insures that tasking is initialized if any protected objects are
  66 --  created.
  67
  68 with System.Restrictions;
  69 --  Used for Abort_Allowed
  70
  71 with System.Parameters;
  72 --  Used for Single_Lock
  73
  74 package body System.Tasking.Protected_Objects.Entries is
  75
  76    package STPO renames System.Task_Primitives.Operations;
  77
  78    use Parameters;
  79    use Task_Primitives.Operations;
  80    use Ada.Exceptions;
  81
  82    ----------------
  83    -- Local Data --
  84    ----------------
  85
  86    Locking_Policy : Character;
  87    pragma Import (C, Locking_Policy, "__gl_locking_policy");
  88
  89    --------------
  90    -- Finalize --
  91    --------------
  92
  93    procedure Finalize (Object : in out Protection_Entries) is
  94       Entry_Call        : Entry_Call_Link;
  95       Caller            : Task_Id;
  96       Ceiling_Violation : Boolean;
  97       Self_ID           : constant Task_Id := STPO.Self;
  98       Old_Base_Priority : System.Any_Priority;
  99
 100    begin
 101       if Object.Finalized then
 102          return;
 103       end if;
 104
 105       STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
 106
 107       if Single_Lock then
 108          Lock_RTS;
 109       end if;
 110
 111       if Ceiling_Violation then
 112
 113          --  Dip our own priority down to ceiling of lock. See similar code in
 114          --  Tasking.Entry_Calls.Lock_Server.
 115
 116          STPO.Write_Lock (Self_ID);
 117          Old_Base_Priority := Self_ID.Common.Base_Priority;
 118          Self_ID.New_Base_Priority := Object.Ceiling;
 119          Initialization.Change_Base_Priority (Self_ID);
 120          STPO.Unlock (Self_ID);
 121
 122          if Single_Lock then
 123             Unlock_RTS;
 124          end if;
 125
 126          STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
 127
 128          if Ceiling_Violation then
 129             Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 130          end if;
 131
 132          if Single_Lock then
 133             Lock_RTS;
 134          end if;
 135
 136          Object.Old_Base_Priority := Old_Base_Priority;
 137          Object.Pending_Action := True;
 138       end if;
 139
 140       --  Send program_error to all tasks still queued on this object
 141
 142       for E in Object.Entry_Queues'Range loop
 143          Entry_Call := Object.Entry_Queues (E).Head;
 144
 145          while Entry_Call /= null loop
 146             Caller := Entry_Call.Self;
 147             Entry_Call.Exception_To_Raise := Program_Error'Identity;
 148
 149             STPO.Write_Lock (Caller);
 150             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 151             STPO.Unlock (Caller);
 152
 153             exit when Entry_Call = Object.Entry_Queues (E).Tail;
 154             Entry_Call := Entry_Call.Next;
 155          end loop;
 156       end loop;
 157
 158       Object.Finalized := True;
 159
 160       if Single_Lock then
 161          Unlock_RTS;
 162       end if;
 163
 164       STPO.Unlock (Object.L'Unrestricted_Access);
 165
 166       STPO.Finalize_Lock (Object.L'Unrestricted_Access);
 167    end Finalize;
 168
 169    -----------------
 170    -- Get_Ceiling --
 171    -----------------
 172
 173    function Get_Ceiling
 174      (Object : Protection_Entries_Access) return System.Any_Priority is
 175    begin
 176       return Object.New_Ceiling;
 177    end Get_Ceiling;
 178
 179    -------------------------------------
 180    -- Has_Interrupt_Or_Attach_Handler --
 181    -------------------------------------
 182
 183    function Has_Interrupt_Or_Attach_Handler
 184      (Object : Protection_Entries_Access)
 185       return   Boolean
 186    is
 187       pragma Warnings (Off, Object);
 188    begin
 189       return False;
 190    end Has_Interrupt_Or_Attach_Handler;
 191
 192    -----------------------------------
 193    -- Initialize_Protection_Entries --
 194    -----------------------------------
 195
 196    procedure Initialize_Protection_Entries
 197      (Object            : Protection_Entries_Access;
 198       Ceiling_Priority  : Integer;
 199       Compiler_Info     : System.Address;
 200       Entry_Bodies      : Protected_Entry_Body_Access;
 201       Find_Body_Index   : Find_Body_Index_Access)
 202    is
 203       Init_Priority : Integer := Ceiling_Priority;
 204       Self_ID       : constant Task_Id := STPO.Self;
 205
 206    begin
 207       if Init_Priority = Unspecified_Priority then
 208          Init_Priority  := System.Priority'Last;
 209       end if;
 210
 211       if Locking_Policy = 'C'
 212         and then Has_Interrupt_Or_Attach_Handler (Object)
 213         and then Init_Priority not in System.Interrupt_Priority
 214       then
 215          --  Required by C.3.1(11)
 216
 217          raise Program_Error;
 218       end if;
 219
 220       Initialization.Defer_Abort (Self_ID);
 221       Initialize_Lock (Init_Priority, Object.L'Access);
 222       Initialization.Undefer_Abort (Self_ID);
 223
 224       Object.Ceiling          := System.Any_Priority (Init_Priority);
 225       Object.New_Ceiling      := System.Any_Priority (Init_Priority);
 226       Object.Owner            := Null_Task;
 227       Object.Compiler_Info    := Compiler_Info;
 228       Object.Pending_Action   := False;
 229       Object.Call_In_Progress := null;
 230       Object.Entry_Bodies     := Entry_Bodies;
 231       Object.Find_Body_Index  := Find_Body_Index;
 232
 233       for E in Object.Entry_Queues'Range loop
 234          Object.Entry_Queues (E).Head := null;
 235          Object.Entry_Queues (E).Tail := null;
 236       end loop;
 237    end Initialize_Protection_Entries;
 238
 239    ------------------
 240    -- Lock_Entries --
 241    ------------------
 242
 243    procedure Lock_Entries
 244      (Object            : Protection_Entries_Access;
 245       Ceiling_Violation : out Boolean)
 246    is
 247    begin
 248       if Object.Finalized then
 249          Raise_Exception
 250            (Program_Error'Identity, "Protected Object is finalized");
 251       end if;
 252
 253       --  If pragma Detect_Blocking is active then, as described in the ARM
 254       --  9.5.1, par. 15, we must check whether this is an external call on a
 255       --  protected subprogram with the same target object as that of the
 256       --  protected action that is currently in progress (i.e., if the caller
 257       --  is already the protected object's owner). If this is the case hence
 258       --  Program_Error must be raised.
 259
 260       if Detect_Blocking and then Object.Owner = Self then
 261          raise Program_Error;
 262       end if;
 263
 264       --  The lock is made without defering abort
 265
 266       --  Therefore the abort has to be deferred before calling this routine.
 267       --  This means that the compiler has to generate a Defer_Abort call
 268       --  before the call to Lock.
 269
 270       --  The caller is responsible for undeferring abort, and compiler
 271       --  generated calls must be protected with cleanup handlers to ensure
 272       --  that abort is undeferred in all cases.
 273
 274       pragma Assert
 275         (STPO.Self.Deferral_Level > 0
 276           or else not Restrictions.Abort_Allowed);
 277
 278       Write_Lock (Object.L'Access, Ceiling_Violation);
 279
 280       --  We are entering in a protected action, so that we increase the
 281       --  protected object nesting level (if pragma Detect_Blocking is
 282       --  active), and update the protected object's owner.
 283
 284       if Detect_Blocking then
 285          declare
 286             Self_Id : constant Task_Id := Self;
 287
 288          begin
 289             --  Update the protected object's owner
 290
 291             Object.Owner := Self_Id;
 292
 293             --  Increase protected object nesting level
 294
 295             Self_Id.Common.Protected_Action_Nesting :=
 296               Self_Id.Common.Protected_Action_Nesting + 1;
 297          end;
 298       end if;
 299
 300    end Lock_Entries;
 301
 302    procedure Lock_Entries (Object : Protection_Entries_Access) is
 303       Ceiling_Violation : Boolean;
 304
 305    begin
 306       Lock_Entries (Object, Ceiling_Violation);
 307
 308       if Ceiling_Violation then
 309          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 310       end if;
 311    end Lock_Entries;
 312
 313    ----------------------------
 314    -- Lock_Read_Only_Entries --
 315    ----------------------------
 316
 317    procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
 318       Ceiling_Violation : Boolean;
 319
 320    begin
 321       if Object.Finalized then
 322          Raise_Exception
 323            (Program_Error'Identity, "Protected Object is finalized");
 324       end if;
 325
 326       --  If pragma Detect_Blocking is active then, as described in the ARM
 327       --  9.5.1, par. 15, we must check whether this is an external call on a
 328       --  protected subprogram with the same target object as that of the
 329       --  protected action that is currently in progress (i.e., if the caller
 330       --  is already the protected object's owner). If this is the case hence
 331       --  Program_Error must be raised.
 332
 333       --  Note that in this case (getting read access), several tasks may
 334       --  have read ownership of the protected object, so that this method of
 335       --  storing the (single) protected object's owner does not work
 336       --  reliably for read locks. However, this is the approach taken for two
 337       --  major reasosn: first, this function is not currently being used (it
 338       --  is provided for possible future use), and second, it largely
 339       --  simplifies the implementation.
 340
 341       if Detect_Blocking and then Object.Owner = Self then
 342          raise Program_Error;
 343       end if;
 344
 345       Read_Lock (Object.L'Access, Ceiling_Violation);
 346
 347       if Ceiling_Violation then
 348          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
 349       end if;
 350
 351       --  We are entering in a protected action, so that we increase the
 352       --  protected object nesting level (if pragma Detect_Blocking is
 353       --  active), and update the protected object's owner.
 354
 355       if Detect_Blocking then
 356          declare
 357             Self_Id : constant Task_Id := Self;
 358
 359          begin
 360             --  Update the protected object's owner
 361
 362             Object.Owner := Self_Id;
 363
 364             --  Increase protected object nesting level
 365
 366             Self_Id.Common.Protected_Action_Nesting :=
 367               Self_Id.Common.Protected_Action_Nesting + 1;
 368          end;
 369       end if;
 370    end Lock_Read_Only_Entries;
 371
 372    -----------------
 373    -- Set_Ceiling --
 374    -----------------
 375
 376    procedure Set_Ceiling
 377      (Object : Protection_Entries_Access;
 378       Prio   : System.Any_Priority) is
 379    begin
 380       Object.New_Ceiling := Prio;
 381    end Set_Ceiling;
 382
 383    --------------------
 384    -- Unlock_Entries --
 385    --------------------
 386
 387    procedure Unlock_Entries (Object : Protection_Entries_Access) is
 388    begin
 389       --  We are exiting from a protected action, so that we decrease the
 390       --  protected object nesting level (if pragma Detect_Blocking is
 391       --  active), and remove ownership of the protected object.
 392
 393       if Detect_Blocking then
 394          declare
 395             Self_Id : constant Task_Id := Self;
 396
 397          begin
 398             --  Calls to this procedure can only take place when being within
 399             --  a protected action and when the caller is the protected
 400             --  object's owner.
 401
 402             pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
 403                              and then Object.Owner = Self_Id);
 404
 405             --  Remove ownership of the protected object
 406
 407             Object.Owner := Null_Task;
 408
 409             Self_Id.Common.Protected_Action_Nesting :=
 410               Self_Id.Common.Protected_Action_Nesting - 1;
 411          end;
 412       end if;
 413
 414       --  Before releasing the mutex we must actually update its ceiling
 415       --  priority if it has been changed.
 416
 417       if Object.New_Ceiling /= Object.Ceiling then
 418          if Locking_Policy = 'C' then
 419             System.Task_Primitives.Operations.Set_Ceiling
 420               (Object.L'Access, Object.New_Ceiling);
 421          end if;
 422
 423          Object.Ceiling := Object.New_Ceiling;
 424       end if;
 425
 426       Unlock (Object.L'Access);
 427    end Unlock_Entries;
 428
 429 end System.Tasking.Protected_Objects.Entries;