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