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