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