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 System.Task_Primitives.Operations;
47 with System.Restrictions;
48 with System.Parameters;
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
54 package body System.Tasking.Protected_Objects.Entries is
56 package STPO renames System.Task_Primitives.Operations;
59 use Task_Primitives.Operations;
65 Locking_Policy : Character;
66 pragma Import (C, Locking_Policy, "__gl_locking_policy");
72 procedure Finalize (Object : in out Protection_Entries) is
73 Entry_Call : Entry_Call_Link;
75 Ceiling_Violation : Boolean;
76 Self_ID : constant Task_Id := STPO.Self;
77 Old_Base_Priority : System.Any_Priority;
80 if Object.Finalized then
84 STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
90 if Ceiling_Violation then
92 -- Dip our own priority down to ceiling of lock. See similar code in
93 -- Tasking.Entry_Calls.Lock_Server.
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);
105 STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
107 if Ceiling_Violation then
108 raise Program_Error with "Ceiling Violation";
115 Object.Old_Base_Priority := Old_Base_Priority;
116 Object.Pending_Action := True;
119 -- Send program_error to all tasks still queued on this object
121 for E in Object.Entry_Queues'Range loop
122 Entry_Call := Object.Entry_Queues (E).Head;
124 while Entry_Call /= null loop
125 Caller := Entry_Call.Self;
126 Entry_Call.Exception_To_Raise := Program_Error'Identity;
128 STPO.Write_Lock (Caller);
129 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
130 STPO.Unlock (Caller);
132 exit when Entry_Call = Object.Entry_Queues (E).Tail;
133 Entry_Call := Entry_Call.Next;
137 Object.Finalized := True;
143 STPO.Unlock (Object.L'Unrestricted_Access);
145 STPO.Finalize_Lock (Object.L'Unrestricted_Access);
153 (Object : Protection_Entries_Access) return System.Any_Priority is
155 return Object.New_Ceiling;
158 -------------------------------------
159 -- Has_Interrupt_Or_Attach_Handler --
160 -------------------------------------
162 function Has_Interrupt_Or_Attach_Handler
163 (Object : Protection_Entries_Access)
166 pragma Warnings (Off, Object);
169 end Has_Interrupt_Or_Attach_Handler;
171 -----------------------------------
172 -- Initialize_Protection_Entries --
173 -----------------------------------
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)
182 Init_Priority : Integer := Ceiling_Priority;
183 Self_ID : constant Task_Id := STPO.Self;
186 if Init_Priority = Unspecified_Priority then
187 Init_Priority := System.Priority'Last;
190 if Locking_Policy = 'C'
191 and then Has_Interrupt_Or_Attach_Handler (Object)
192 and then Init_Priority not in System.Interrupt_Priority
194 -- Required by C.3.1(11)
199 Initialization.Defer_Abort (Self_ID);
200 Initialize_Lock (Init_Priority, Object.L'Access);
201 Initialization.Undefer_Abort (Self_ID);
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;
212 for E in Object.Entry_Queues'Range loop
213 Object.Entry_Queues (E).Head := null;
214 Object.Entry_Queues (E).Tail := null;
216 end Initialize_Protection_Entries;
222 procedure Lock_Entries
223 (Object : Protection_Entries_Access;
224 Ceiling_Violation : out Boolean)
227 if Object.Finalized then
228 raise Program_Error with "Protected Object is finalized";
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.
238 if Detect_Blocking and then Object.Owner = Self then
242 -- The lock is made without deferring abort
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.
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.
253 (STPO.Self.Deferral_Level > 0
254 or else not Restrictions.Abort_Allowed);
256 Write_Lock (Object.L'Access, Ceiling_Violation);
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.
262 if Detect_Blocking then
264 Self_Id : constant Task_Id := Self;
267 -- Update the protected object's owner
269 Object.Owner := Self_Id;
271 -- Increase protected object nesting level
273 Self_Id.Common.Protected_Action_Nesting :=
274 Self_Id.Common.Protected_Action_Nesting + 1;
280 procedure Lock_Entries (Object : Protection_Entries_Access) is
281 Ceiling_Violation : Boolean;
284 Lock_Entries (Object, Ceiling_Violation);
286 if Ceiling_Violation then
287 raise Program_Error with "Ceiling Violation";
291 ----------------------------
292 -- Lock_Read_Only_Entries --
293 ----------------------------
295 procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
296 Ceiling_Violation : Boolean;
299 if Object.Finalized then
300 raise Program_Error with "Protected Object is finalized";
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.
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 reasons: first, this function is not currently being used (it
315 -- is provided for possible future use), and second, it largely
316 -- simplifies the implementation.
318 if Detect_Blocking and then Object.Owner = Self then
322 Read_Lock (Object.L'Access, Ceiling_Violation);
324 if Ceiling_Violation then
325 raise Program_Error with "Ceiling Violation";
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.
332 if Detect_Blocking then
334 Self_Id : constant Task_Id := Self;
337 -- Update the protected object's owner
339 Object.Owner := Self_Id;
341 -- Increase protected object nesting level
343 Self_Id.Common.Protected_Action_Nesting :=
344 Self_Id.Common.Protected_Action_Nesting + 1;
347 end Lock_Read_Only_Entries;
353 procedure Set_Ceiling
354 (Object : Protection_Entries_Access;
355 Prio : System.Any_Priority) is
357 Object.New_Ceiling := Prio;
364 procedure Unlock_Entries (Object : Protection_Entries_Access) is
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.
370 if Detect_Blocking then
372 Self_Id : constant Task_Id := Self;
375 -- Calls to this procedure can only take place when being within
376 -- a protected action and when the caller is the protected
379 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
380 and then Object.Owner = Self_Id);
382 -- Remove ownership of the protected object
384 Object.Owner := Null_Task;
386 Self_Id.Common.Protected_Action_Nesting :=
387 Self_Id.Common.Protected_Action_Nesting - 1;
391 -- Before releasing the mutex we must actually update its ceiling
392 -- priority if it has been changed.
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);
400 Object.Ceiling := Object.New_Ceiling;
403 Unlock (Object.L'Access);
406 end System.Tasking.Protected_Objects.Entries;