gcc/ada/s-tpoben.adb

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