gcc/ada/s-tpoben.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                  --
   4 --                                                                          --
   5 --                SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES                  --
   6 --                                                                          --
   7 --                               B o d y                                    --
   8 --                                                                          --
   9 --          Copyright (C) 1998-2011, 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 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT 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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNARL was developed by the GNARL team at Florida State University.       --
  28 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  This package contains all the simple primitives related to protected
  33 --  objects with entries (i.e init, lock, unlock).
  34
  35 --  The handling of protected objects with no entries is done in
  36 --  System.Tasking.Protected_Objects, the complex routines for protected
  37 --  objects with entries in System.Tasking.Protected_Objects.Operations.
  38
  39 --  The split between Entries and Operations is needed to break circular
  40 --  dependencies inside the run time.
  41
  42 --  Note: the compiler generates direct calls to this interface, via Rtsfind
  43
  44 with Ada.Unchecked_Deallocation;
  45
  46 with System.Task_Primitives.Operations;
  47 with System.Restrictions;
  48 with System.Parameters;
  49
  50 with System.Tasking.Initialization;
  51 pragma Elaborate_All (System.Tasking.Initialization);
  52 --  To insure that tasking is initialized if any protected objects are created
  53
  54 package body System.Tasking.Protected_Objects.Entries is
  55
  56    package STPO renames System.Task_Primitives.Operations;
  57
  58    use Parameters;
  59    use Task_Primitives.Operations;
  60
  61    -----------------------
  62    -- Local Subprograms --
  63    -----------------------
  64
  65    procedure Free_Entry_Names (Object : Protection_Entries);
  66    --  Deallocate all string names associated with protected entries
  67
  68    ----------------
  69    -- Local Data --
  70    ----------------
  71
  72    Locking_Policy : Character;
  73    pragma Import (C, Locking_Policy, "__gl_locking_policy");
  74
  75    --------------
  76    -- Finalize --
  77    --------------
  78
  79    overriding procedure Finalize (Object : in out Protection_Entries) is
  80       Entry_Call        : Entry_Call_Link;
  81       Caller            : Task_Id;
  82       Ceiling_Violation : Boolean;
  83       Self_ID           : constant Task_Id := STPO.Self;
  84       Old_Base_Priority : System.Any_Priority;
  85
  86    begin
  87       if Object.Finalized then
  88          return;
  89       end if;
  90
  91       STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
  92
  93       if Single_Lock then
  94          Lock_RTS;
  95       end if;
  96
  97       if Ceiling_Violation then
  98
  99          --  Dip our own priority down to ceiling of lock. See similar code in
 100          --  Tasking.Entry_Calls.Lock_Server.
 101
 102          STPO.Write_Lock (Self_ID);
 103          Old_Base_Priority := Self_ID.Common.Base_Priority;
 104          Self_ID.New_Base_Priority := Object.Ceiling;
 105          Initialization.Change_Base_Priority (Self_ID);
 106          STPO.Unlock (Self_ID);
 107
 108          if Single_Lock then
 109             Unlock_RTS;
 110          end if;
 111
 112          STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
 113
 114          if Ceiling_Violation then
 115             raise Program_Error with "Ceiling Violation";
 116          end if;
 117
 118          if Single_Lock then
 119             Lock_RTS;
 120          end if;
 121
 122          Object.Old_Base_Priority := Old_Base_Priority;
 123          Object.Pending_Action := True;
 124       end if;
 125
 126       --  Send program_error to all tasks still queued on this object
 127
 128       for E in Object.Entry_Queues'Range loop
 129          Entry_Call := Object.Entry_Queues (E).Head;
 130
 131          while Entry_Call /= null loop
 132             Caller := Entry_Call.Self;
 133             Entry_Call.Exception_To_Raise := Program_Error'Identity;
 134
 135             STPO.Write_Lock (Caller);
 136             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 137             STPO.Unlock (Caller);
 138
 139             exit when Entry_Call = Object.Entry_Queues (E).Tail;
 140             Entry_Call := Entry_Call.Next;
 141          end loop;
 142       end loop;
 143
 144       Free_Entry_Names (Object);
 145
 146       Object.Finalized := True;
 147
 148       if Single_Lock then
 149          Unlock_RTS;
 150       end if;
 151
 152       STPO.Unlock (Object.L'Unrestricted_Access);
 153
 154       STPO.Finalize_Lock (Object.L'Unrestricted_Access);
 155    end Finalize;
 156
 157    ----------------------
 158    -- Free_Entry_Names --
 159    ----------------------
 160
 161    procedure Free_Entry_Names (Object : Protection_Entries) is
 162       Names : Entry_Names_Array_Access := Object.Entry_Names;
 163
 164       procedure Free_Entry_Names_Array_Access is new
 165         Ada.Unchecked_Deallocation
 166           (Entry_Names_Array, Entry_Names_Array_Access);
 167
 168    begin
 169       if Names = null then
 170          return;
 171       end if;
 172
 173       Free_Entry_Names_Array (Names.all);
 174       Free_Entry_Names_Array_Access (Names);
 175    end Free_Entry_Names;
 176
 177    -----------------
 178    -- Get_Ceiling --
 179    -----------------
 180
 181    function Get_Ceiling
 182      (Object : Protection_Entries_Access) return System.Any_Priority is
 183    begin
 184       return Object.New_Ceiling;
 185    end Get_Ceiling;
 186
 187    -------------------------------------
 188    -- Has_Interrupt_Or_Attach_Handler --
 189    -------------------------------------
 190
 191    function Has_Interrupt_Or_Attach_Handler
 192      (Object : Protection_Entries_Access)
 193       return   Boolean
 194    is
 195       pragma Warnings (Off, Object);
 196    begin
 197       return False;
 198    end Has_Interrupt_Or_Attach_Handler;
 199
 200    -----------------------------------
 201    -- Initialize_Protection_Entries --
 202    -----------------------------------
 203
 204    procedure Initialize_Protection_Entries
 205      (Object            : Protection_Entries_Access;
 206       Ceiling_Priority  : Integer;
 207       Compiler_Info     : System.Address;
 208       Entry_Bodies      : Protected_Entry_Body_Access;
 209       Find_Body_Index   : Find_Body_Index_Access;
 210       Build_Entry_Names : Boolean)
 211    is
 212       Init_Priority : Integer := Ceiling_Priority;
 213       Self_ID       : constant Task_Id := STPO.Self;
 214
 215    begin
 216       if Init_Priority = Unspecified_Priority then
 217          Init_Priority := System.Priority'Last;
 218       end if;
 219
 220       if Locking_Policy = 'C'
 221         and then Has_Interrupt_Or_Attach_Handler (Object)
 222         and then Init_Priority not in System.Interrupt_Priority
 223       then
 224          --  Required by C.3.1(11)
 225
 226          raise Program_Error;
 227       end if;
 228
 229       --  If a PO is created from a controlled operation, abort is already
 230       --  deferred at this point, so we need to use Defer_Abort_Nestable. In
 231       --  some cases, the following assertion can help to spot inconsistencies,
 232       --  outside the above scenario involving controlled types.
 233
 234       --  pragma Assert (Self_Id.Deferral_Level = 0);
 235
 236       Initialization.Defer_Abort_Nestable (Self_ID);
 237       Initialize_Lock (Init_Priority, Object.L'Access);
 238       Initialization.Undefer_Abort_Nestable (Self_ID);
 239
 240       Object.Ceiling          := System.Any_Priority (Init_Priority);
 241       Object.New_Ceiling      := System.Any_Priority (Init_Priority);
 242       Object.Owner            := Null_Task;
 243       Object.Compiler_Info    := Compiler_Info;
 244       Object.Pending_Action   := False;
 245       Object.Call_In_Progress := null;
 246       Object.Entry_Bodies     := Entry_Bodies;
 247       Object.Find_Body_Index  := Find_Body_Index;
 248
 249       for E in Object.Entry_Queues'Range loop
 250          Object.Entry_Queues (E).Head := null;
 251          Object.Entry_Queues (E).Tail := null;
 252       end loop;
 253
 254       if Build_Entry_Names then
 255          Object.Entry_Names :=
 256            new Entry_Names_Array (1 .. Entry_Index (Object.Num_Entries));
 257       end if;
 258    end Initialize_Protection_Entries;
 259
 260    ------------------
 261    -- Lock_Entries --
 262    ------------------
 263
 264    procedure Lock_Entries (Object : Protection_Entries_Access) is
 265       Ceiling_Violation : Boolean;
 266
 267    begin
 268       Lock_Entries_With_Status (Object, Ceiling_Violation);
 269
 270       if Ceiling_Violation then
 271          raise Program_Error with "Ceiling Violation";
 272       end if;
 273    end Lock_Entries;
 274
 275    ------------------------------
 276    -- Lock_Entries_With_Status --
 277    ------------------------------
 278
 279    procedure Lock_Entries_With_Status
 280      (Object            : Protection_Entries_Access;
 281       Ceiling_Violation : out Boolean)
 282    is
 283    begin
 284       if Object.Finalized then
 285          raise Program_Error with "Protected Object is finalized";
 286       end if;
 287
 288       --  If pragma Detect_Blocking is active then, as described in the ARM
 289       --  9.5.1, par. 15, we must check whether this is an external call on a
 290       --  protected subprogram with the same target object as that of the
 291       --  protected action that is currently in progress (i.e., if the caller
 292       --  is already the protected object's owner). If this is the case hence
 293       --  Program_Error must be raised.
 294
 295       if Detect_Blocking and then Object.Owner = Self then
 296          raise Program_Error;
 297       end if;
 298
 299       --  The lock is made without deferring abort
 300
 301       --  Therefore the abort has to be deferred before calling this routine.
 302       --  This means that the compiler has to generate a Defer_Abort call
 303       --  before the call to Lock.
 304
 305       --  The caller is responsible for undeferring abort, and compiler
 306       --  generated calls must be protected with cleanup handlers to ensure
 307       --  that abort is undeferred in all cases.
 308
 309       pragma Assert
 310         (STPO.Self.Deferral_Level > 0
 311           or else not Restrictions.Abort_Allowed);
 312
 313       Write_Lock (Object.L'Access, Ceiling_Violation);
 314
 315       --  We are entering in a protected action, so that we increase the
 316       --  protected object nesting level (if pragma Detect_Blocking is
 317       --  active), and update the protected object's owner.
 318
 319       if Detect_Blocking then
 320          declare
 321             Self_Id : constant Task_Id := Self;
 322
 323          begin
 324             --  Update the protected object's owner
 325
 326             Object.Owner := Self_Id;
 327
 328             --  Increase protected object nesting level
 329
 330             Self_Id.Common.Protected_Action_Nesting :=
 331               Self_Id.Common.Protected_Action_Nesting + 1;
 332          end;
 333       end if;
 334    end Lock_Entries_With_Status;
 335
 336    ----------------------------
 337    -- Lock_Read_Only_Entries --
 338    ----------------------------
 339
 340    procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
 341       Ceiling_Violation : Boolean;
 342
 343    begin
 344       if Object.Finalized then
 345          raise Program_Error with "Protected Object is finalized";
 346       end if;
 347
 348       --  If pragma Detect_Blocking is active then, as described in the ARM
 349       --  9.5.1, par. 15, we must check whether this is an external call on a
 350       --  protected subprogram with the same target object as that of the
 351       --  protected action that is currently in progress (i.e., if the caller
 352       --  is already the protected object's owner). If this is the case hence
 353       --  Program_Error must be raised.
 354
 355       --  Note that in this case (getting read access), several tasks may
 356       --  have read ownership of the protected object, so that this method of
 357       --  storing the (single) protected object's owner does not work
 358       --  reliably for read locks. However, this is the approach taken for two
 359       --  major reasons: first, this function is not currently being used (it
 360       --  is provided for possible future use), and second, it largely
 361       --  simplifies the implementation.
 362
 363       if Detect_Blocking and then Object.Owner = Self then
 364          raise Program_Error;
 365       end if;
 366
 367       Read_Lock (Object.L'Access, Ceiling_Violation);
 368
 369       if Ceiling_Violation then
 370          raise Program_Error with "Ceiling Violation";
 371       end if;
 372
 373       --  We are entering in a protected action, so that we increase the
 374       --  protected object nesting level (if pragma Detect_Blocking is
 375       --  active), and update the protected object's owner.
 376
 377       if Detect_Blocking then
 378          declare
 379             Self_Id : constant Task_Id := Self;
 380
 381          begin
 382             --  Update the protected object's owner
 383
 384             Object.Owner := Self_Id;
 385
 386             --  Increase protected object nesting level
 387
 388             Self_Id.Common.Protected_Action_Nesting :=
 389               Self_Id.Common.Protected_Action_Nesting + 1;
 390          end;
 391       end if;
 392    end Lock_Read_Only_Entries;
 393
 394    -----------------
 395    -- Set_Ceiling --
 396    -----------------
 397
 398    procedure Set_Ceiling
 399      (Object : Protection_Entries_Access;
 400       Prio   : System.Any_Priority) is
 401    begin
 402       Object.New_Ceiling := Prio;
 403    end Set_Ceiling;
 404
 405    --------------------
 406    -- Set_Entry_Name --
 407    --------------------
 408
 409    procedure Set_Entry_Name
 410      (Object : Protection_Entries'Class;
 411       Pos    : Protected_Entry_Index;
 412       Val    : String_Access)
 413    is
 414    begin
 415       pragma Assert (Object.Entry_Names /= null);
 416
 417       Object.Entry_Names (Entry_Index (Pos)) := Val;
 418    end Set_Entry_Name;
 419
 420    --------------------
 421    -- Unlock_Entries --
 422    --------------------
 423
 424    procedure Unlock_Entries (Object : Protection_Entries_Access) is
 425    begin
 426       --  We are exiting from a protected action, so that we decrease the
 427       --  protected object nesting level (if pragma Detect_Blocking is
 428       --  active), and remove ownership of the protected object.
 429
 430       if Detect_Blocking then
 431          declare
 432             Self_Id : constant Task_Id := Self;
 433
 434          begin
 435             --  Calls to this procedure can only take place when being within
 436             --  a protected action and when the caller is the protected
 437             --  object's owner.
 438
 439             pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
 440                              and then Object.Owner = Self_Id);
 441
 442             --  Remove ownership of the protected object
 443
 444             Object.Owner := Null_Task;
 445
 446             Self_Id.Common.Protected_Action_Nesting :=
 447               Self_Id.Common.Protected_Action_Nesting - 1;
 448          end;
 449       end if;
 450
 451       --  Before releasing the mutex we must actually update its ceiling
 452       --  priority if it has been changed.
 453
 454       if Object.New_Ceiling /= Object.Ceiling then
 455          if Locking_Policy = 'C' then
 456             System.Task_Primitives.Operations.Set_Ceiling
 457               (Object.L'Access, Object.New_Ceiling);
 458          end if;
 459
 460          Object.Ceiling := Object.New_Ceiling;
 461       end if;
 462
 463       Unlock (Object.L'Access);
 464    end Unlock_Entries;
 465
 466 end System.Tasking.Protected_Objects.Entries;