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-2009, 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       Initialization.Defer_Abort (Self_ID);
 230       Initialize_Lock (Init_Priority, Object.L'Access);
 231       Initialization.Undefer_Abort (Self_ID);
 232
 233       Object.Ceiling          := System.Any_Priority (Init_Priority);
 234       Object.New_Ceiling      := System.Any_Priority (Init_Priority);
 235       Object.Owner            := Null_Task;
 236       Object.Compiler_Info    := Compiler_Info;
 237       Object.Pending_Action   := False;
 238       Object.Call_In_Progress := null;
 239       Object.Entry_Bodies     := Entry_Bodies;
 240       Object.Find_Body_Index  := Find_Body_Index;
 241
 242       for E in Object.Entry_Queues'Range loop
 243          Object.Entry_Queues (E).Head := null;
 244          Object.Entry_Queues (E).Tail := null;
 245       end loop;
 246
 247       if Build_Entry_Names then
 248          Object.Entry_Names :=
 249            new Entry_Names_Array (1 .. Entry_Index (Object.Num_Entries));
 250       end if;
 251    end Initialize_Protection_Entries;
 252
 253    ------------------
 254    -- Lock_Entries --
 255    ------------------
 256
 257    procedure Lock_Entries
 258      (Object            : Protection_Entries_Access;
 259       Ceiling_Violation : out Boolean)
 260    is
 261    begin
 262       if Object.Finalized then
 263          raise Program_Error with "Protected Object is finalized";
 264       end if;
 265
 266       --  If pragma Detect_Blocking is active then, as described in the ARM
 267       --  9.5.1, par. 15, we must check whether this is an external call on a
 268       --  protected subprogram with the same target object as that of the
 269       --  protected action that is currently in progress (i.e., if the caller
 270       --  is already the protected object's owner). If this is the case hence
 271       --  Program_Error must be raised.
 272
 273       if Detect_Blocking and then Object.Owner = Self then
 274          raise Program_Error;
 275       end if;
 276
 277       --  The lock is made without deferring abort
 278
 279       --  Therefore the abort has to be deferred before calling this routine.
 280       --  This means that the compiler has to generate a Defer_Abort call
 281       --  before the call to Lock.
 282
 283       --  The caller is responsible for undeferring abort, and compiler
 284       --  generated calls must be protected with cleanup handlers to ensure
 285       --  that abort is undeferred in all cases.
 286
 287       pragma Assert
 288         (STPO.Self.Deferral_Level > 0
 289           or else not Restrictions.Abort_Allowed);
 290
 291       Write_Lock (Object.L'Access, Ceiling_Violation);
 292
 293       --  We are entering in a protected action, so that we increase the
 294       --  protected object nesting level (if pragma Detect_Blocking is
 295       --  active), and update the protected object's owner.
 296
 297       if Detect_Blocking then
 298          declare
 299             Self_Id : constant Task_Id := Self;
 300
 301          begin
 302             --  Update the protected object's owner
 303
 304             Object.Owner := Self_Id;
 305
 306             --  Increase protected object nesting level
 307
 308             Self_Id.Common.Protected_Action_Nesting :=
 309               Self_Id.Common.Protected_Action_Nesting + 1;
 310          end;
 311       end if;
 312
 313    end Lock_Entries;
 314
 315    procedure Lock_Entries (Object : Protection_Entries_Access) is
 316       Ceiling_Violation : Boolean;
 317
 318    begin
 319       Lock_Entries (Object, Ceiling_Violation);
 320
 321       if Ceiling_Violation then
 322          raise Program_Error with "Ceiling Violation";
 323       end if;
 324    end Lock_Entries;
 325
 326    ----------------------------
 327    -- Lock_Read_Only_Entries --
 328    ----------------------------
 329
 330    procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
 331       Ceiling_Violation : Boolean;
 332
 333    begin
 334       if Object.Finalized then
 335          raise Program_Error with "Protected Object is finalized";
 336       end if;
 337
 338       --  If pragma Detect_Blocking is active then, as described in the ARM
 339       --  9.5.1, par. 15, we must check whether this is an external call on a
 340       --  protected subprogram with the same target object as that of the
 341       --  protected action that is currently in progress (i.e., if the caller
 342       --  is already the protected object's owner). If this is the case hence
 343       --  Program_Error must be raised.
 344
 345       --  Note that in this case (getting read access), several tasks may
 346       --  have read ownership of the protected object, so that this method of
 347       --  storing the (single) protected object's owner does not work
 348       --  reliably for read locks. However, this is the approach taken for two
 349       --  major reasons: first, this function is not currently being used (it
 350       --  is provided for possible future use), and second, it largely
 351       --  simplifies the implementation.
 352
 353       if Detect_Blocking and then Object.Owner = Self then
 354          raise Program_Error;
 355       end if;
 356
 357       Read_Lock (Object.L'Access, Ceiling_Violation);
 358
 359       if Ceiling_Violation then
 360          raise Program_Error with "Ceiling Violation";
 361       end if;
 362
 363       --  We are entering in a protected action, so that we increase the
 364       --  protected object nesting level (if pragma Detect_Blocking is
 365       --  active), and update the protected object's owner.
 366
 367       if Detect_Blocking then
 368          declare
 369             Self_Id : constant Task_Id := Self;
 370
 371          begin
 372             --  Update the protected object's owner
 373
 374             Object.Owner := Self_Id;
 375
 376             --  Increase protected object nesting level
 377
 378             Self_Id.Common.Protected_Action_Nesting :=
 379               Self_Id.Common.Protected_Action_Nesting + 1;
 380          end;
 381       end if;
 382    end Lock_Read_Only_Entries;
 383
 384    -----------------
 385    -- Set_Ceiling --
 386    -----------------
 387
 388    procedure Set_Ceiling
 389      (Object : Protection_Entries_Access;
 390       Prio   : System.Any_Priority) is
 391    begin
 392       Object.New_Ceiling := Prio;
 393    end Set_Ceiling;
 394
 395    --------------------
 396    -- Set_Entry_Name --
 397    --------------------
 398
 399    procedure Set_Entry_Name
 400      (Object : Protection_Entries'Class;
 401       Pos    : Protected_Entry_Index;
 402       Val    : String_Access)
 403    is
 404    begin
 405       pragma Assert (Object.Entry_Names /= null);
 406
 407       Object.Entry_Names (Entry_Index (Pos)) := Val;
 408    end Set_Entry_Name;
 409
 410    --------------------
 411    -- Unlock_Entries --
 412    --------------------
 413
 414    procedure Unlock_Entries (Object : Protection_Entries_Access) is
 415    begin
 416       --  We are exiting from a protected action, so that we decrease the
 417       --  protected object nesting level (if pragma Detect_Blocking is
 418       --  active), and remove ownership of the protected object.
 419
 420       if Detect_Blocking then
 421          declare
 422             Self_Id : constant Task_Id := Self;
 423
 424          begin
 425             --  Calls to this procedure can only take place when being within
 426             --  a protected action and when the caller is the protected
 427             --  object's owner.
 428
 429             pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
 430                              and then Object.Owner = Self_Id);
 431
 432             --  Remove ownership of the protected object
 433
 434             Object.Owner := Null_Task;
 435
 436             Self_Id.Common.Protected_Action_Nesting :=
 437               Self_Id.Common.Protected_Action_Nesting - 1;
 438          end;
 439       end if;
 440
 441       --  Before releasing the mutex we must actually update its ceiling
 442       --  priority if it has been changed.
 443
 444       if Object.New_Ceiling /= Object.Ceiling then
 445          if Locking_Policy = 'C' then
 446             System.Task_Primitives.Operations.Set_Ceiling
 447               (Object.L'Access, Object.New_Ceiling);
 448          end if;
 449
 450          Object.Ceiling := Object.New_Ceiling;
 451       end if;
 452
 453       Unlock (Object.L'Access);
 454    end Unlock_Entries;
 455
 456 end System.Tasking.Protected_Objects.Entries;