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