1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES --
9 -- Copyright (C) 1998-2008, Free Software Foundation, Inc. --
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. --
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. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This package contains all the simple primitives related to protected
35 -- objects with entries (i.e init, lock, unlock).
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.
41 -- The split between Entries and Operations is needed to break circular
42 -- dependencies inside the run time.
44 -- Note: the compiler generates direct calls to this interface, via Rtsfind
46 with Ada.Unchecked_Deallocation;
48 with System.Task_Primitives.Operations;
49 with System.Restrictions;
50 with System.Parameters;
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
56 package body System.Tasking.Protected_Objects.Entries is
58 package STPO renames System.Task_Primitives.Operations;
61 use Task_Primitives.Operations;
63 -----------------------
64 -- Local Subprograms --
65 -----------------------
67 procedure Free_Entry_Names (Object : Protection_Entries);
68 -- Deallocate all string names associated with protected entries
74 Locking_Policy : Character;
75 pragma Import (C, Locking_Policy, "__gl_locking_policy");
81 procedure Finalize (Object : in out Protection_Entries) is
82 Entry_Call : Entry_Call_Link;
84 Ceiling_Violation : Boolean;
85 Self_ID : constant Task_Id := STPO.Self;
86 Old_Base_Priority : System.Any_Priority;
89 if Object.Finalized then
93 STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
99 if Ceiling_Violation then
101 -- Dip our own priority down to ceiling of lock. See similar code in
102 -- Tasking.Entry_Calls.Lock_Server.
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);
114 STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
116 if Ceiling_Violation then
117 raise Program_Error with "Ceiling Violation";
124 Object.Old_Base_Priority := Old_Base_Priority;
125 Object.Pending_Action := True;
128 -- Send program_error to all tasks still queued on this object
130 for E in Object.Entry_Queues'Range loop
131 Entry_Call := Object.Entry_Queues (E).Head;
133 while Entry_Call /= null loop
134 Caller := Entry_Call.Self;
135 Entry_Call.Exception_To_Raise := Program_Error'Identity;
137 STPO.Write_Lock (Caller);
138 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
139 STPO.Unlock (Caller);
141 exit when Entry_Call = Object.Entry_Queues (E).Tail;
142 Entry_Call := Entry_Call.Next;
146 Free_Entry_Names (Object);
148 Object.Finalized := True;
154 STPO.Unlock (Object.L'Unrestricted_Access);
156 STPO.Finalize_Lock (Object.L'Unrestricted_Access);
159 ----------------------
160 -- Free_Entry_Names --
161 ----------------------
163 procedure Free_Entry_Names (Object : Protection_Entries) is
164 Names : Entry_Names_Array_Access := Object.Entry_Names;
166 procedure Free_Entry_Names_Array_Access is new
167 Ada.Unchecked_Deallocation
168 (Entry_Names_Array, Entry_Names_Array_Access);
175 Free_Entry_Names_Array (Names.all);
176 Free_Entry_Names_Array_Access (Names);
177 end Free_Entry_Names;
184 (Object : Protection_Entries_Access) return System.Any_Priority is
186 return Object.New_Ceiling;
189 -------------------------------------
190 -- Has_Interrupt_Or_Attach_Handler --
191 -------------------------------------
193 function Has_Interrupt_Or_Attach_Handler
194 (Object : Protection_Entries_Access)
197 pragma Warnings (Off, Object);
200 end Has_Interrupt_Or_Attach_Handler;
202 -----------------------------------
203 -- Initialize_Protection_Entries --
204 -----------------------------------
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)
214 Init_Priority : Integer := Ceiling_Priority;
215 Self_ID : constant Task_Id := STPO.Self;
218 if Init_Priority = Unspecified_Priority then
219 Init_Priority := System.Priority'Last;
222 if Locking_Policy = 'C'
223 and then Has_Interrupt_Or_Attach_Handler (Object)
224 and then Init_Priority not in System.Interrupt_Priority
226 -- Required by C.3.1(11)
231 Initialization.Defer_Abort (Self_ID);
232 Initialize_Lock (Init_Priority, Object.L'Access);
233 Initialization.Undefer_Abort (Self_ID);
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;
244 for E in Object.Entry_Queues'Range loop
245 Object.Entry_Queues (E).Head := null;
246 Object.Entry_Queues (E).Tail := null;
249 if Build_Entry_Names then
250 Object.Entry_Names :=
251 new Entry_Names_Array (1 .. Entry_Index (Object.Num_Entries));
253 end Initialize_Protection_Entries;
259 procedure Lock_Entries
260 (Object : Protection_Entries_Access;
261 Ceiling_Violation : out Boolean)
264 if Object.Finalized then
265 raise Program_Error with "Protected Object is finalized";
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.
275 if Detect_Blocking and then Object.Owner = Self then
279 -- The lock is made without deferring abort
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.
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.
290 (STPO.Self.Deferral_Level > 0
291 or else not Restrictions.Abort_Allowed);
293 Write_Lock (Object.L'Access, Ceiling_Violation);
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.
299 if Detect_Blocking then
301 Self_Id : constant Task_Id := Self;
304 -- Update the protected object's owner
306 Object.Owner := Self_Id;
308 -- Increase protected object nesting level
310 Self_Id.Common.Protected_Action_Nesting :=
311 Self_Id.Common.Protected_Action_Nesting + 1;
317 procedure Lock_Entries (Object : Protection_Entries_Access) is
318 Ceiling_Violation : Boolean;
321 Lock_Entries (Object, Ceiling_Violation);
323 if Ceiling_Violation then
324 raise Program_Error with "Ceiling Violation";
328 ----------------------------
329 -- Lock_Read_Only_Entries --
330 ----------------------------
332 procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
333 Ceiling_Violation : Boolean;
336 if Object.Finalized then
337 raise Program_Error with "Protected Object is finalized";
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.
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.
355 if Detect_Blocking and then Object.Owner = Self then
359 Read_Lock (Object.L'Access, Ceiling_Violation);
361 if Ceiling_Violation then
362 raise Program_Error with "Ceiling Violation";
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.
369 if Detect_Blocking then
371 Self_Id : constant Task_Id := Self;
374 -- Update the protected object's owner
376 Object.Owner := Self_Id;
378 -- Increase protected object nesting level
380 Self_Id.Common.Protected_Action_Nesting :=
381 Self_Id.Common.Protected_Action_Nesting + 1;
384 end Lock_Read_Only_Entries;
390 procedure Set_Ceiling
391 (Object : Protection_Entries_Access;
392 Prio : System.Any_Priority) is
394 Object.New_Ceiling := Prio;
401 procedure Set_Entry_Name
402 (Object : Protection_Entries'Class;
403 Pos : Protected_Entry_Index;
407 pragma Assert (Object.Entry_Names /= null);
409 Object.Entry_Names (Entry_Index (Pos)) := Val;
416 procedure Unlock_Entries (Object : Protection_Entries_Access) is
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.
422 if Detect_Blocking then
424 Self_Id : constant Task_Id := Self;
427 -- Calls to this procedure can only take place when being within
428 -- a protected action and when the caller is the protected
431 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
432 and then Object.Owner = Self_Id);
434 -- Remove ownership of the protected object
436 Object.Owner := Null_Task;
438 Self_Id.Common.Protected_Action_Nesting :=
439 Self_Id.Common.Protected_Action_Nesting - 1;
443 -- Before releasing the mutex we must actually update its ceiling
444 -- priority if it has been changed.
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);
452 Object.Ceiling := Object.New_Ceiling;
455 Unlock (Object.L'Access);
458 end System.Tasking.Protected_Objects.Entries;