1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
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 . --
10 -- Copyright (C) 1998-2005, Free Software Foundation, Inc. --
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. --
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. --
30 -- GNARL was developed by the GNARL team at Florida State University. --
31 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
33 ------------------------------------------------------------------------------
35 -- This package contains all the simple primitives related to protected
36 -- objects with entries (i.e init, lock, unlock).
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.
42 -- The split between Entries and Operations is needed to break circular
43 -- dependencies inside the run time.
45 -- Note: the compiler generates direct calls to this interface, via Rtsfind
48 -- Used for Exception_Occurrence_Access
51 with System
.Task_Primitives
.Operations
;
52 -- Used for Initialize_Lock
58 with System
.Tasking
.Initialization
;
59 -- Used for Defer_Abort,
61 -- Change_Base_Priority
63 pragma Elaborate_All
(System
.Tasking
.Initialization
);
64 -- This insures that tasking is initialized if any protected objects are
67 with System
.Parameters
;
68 -- Used for Single_Lock
70 package body System
.Tasking
.Protected_Objects
.Entries
is
72 package STPO
renames System
.Task_Primitives
.Operations
;
75 use Task_Primitives
.Operations
;
82 Locking_Policy
: Character;
83 pragma Import
(C
, Locking_Policy
, "__gl_locking_policy");
89 procedure Finalize
(Object
: in out Protection_Entries
) is
90 Entry_Call
: Entry_Call_Link
;
92 Ceiling_Violation
: Boolean;
93 Self_ID
: constant Task_Id
:= STPO
.Self
;
94 Old_Base_Priority
: System
.Any_Priority
;
97 if Object
.Finalized
then
101 STPO
.Write_Lock
(Object
.L
'Unrestricted_Access, Ceiling_Violation
);
107 if Ceiling_Violation
then
109 -- Dip our own priority down to ceiling of lock. See similar code in
110 -- Tasking.Entry_Calls.Lock_Server.
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
);
122 STPO
.Write_Lock
(Object
.L
'Unrestricted_Access, Ceiling_Violation
);
124 if Ceiling_Violation
then
125 Raise_Exception
(Program_Error
'Identity, "Ceiling Violation");
132 Object
.Old_Base_Priority
:= Old_Base_Priority
;
133 Object
.Pending_Action
:= True;
136 -- Send program_error to all tasks still queued on this object
138 for E
in Object
.Entry_Queues
'Range loop
139 Entry_Call
:= Object
.Entry_Queues
(E
).Head
;
141 while Entry_Call
/= null loop
142 Caller
:= Entry_Call
.Self
;
143 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
145 STPO
.Write_Lock
(Caller
);
146 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
147 STPO
.Unlock
(Caller
);
149 exit when Entry_Call
= Object
.Entry_Queues
(E
).Tail
;
150 Entry_Call
:= Entry_Call
.Next
;
154 Object
.Finalized
:= True;
160 STPO
.Unlock
(Object
.L
'Unrestricted_Access);
162 STPO
.Finalize_Lock
(Object
.L
'Unrestricted_Access);
165 -------------------------------------
166 -- Has_Interrupt_Or_Attach_Handler --
167 -------------------------------------
169 function Has_Interrupt_Or_Attach_Handler
170 (Object
: Protection_Entries_Access
)
173 pragma Warnings
(Off
, Object
);
176 end Has_Interrupt_Or_Attach_Handler
;
178 -----------------------------------
179 -- Initialize_Protection_Entries --
180 -----------------------------------
182 procedure Initialize_Protection_Entries
183 (Object
: Protection_Entries_Access
;
184 Ceiling_Priority
: Integer;
185 Compiler_Info
: System
.Address
;
186 Entry_Bodies
: Protected_Entry_Body_Access
;
187 Find_Body_Index
: Find_Body_Index_Access
)
189 Init_Priority
: Integer := Ceiling_Priority
;
190 Self_ID
: constant Task_Id
:= STPO
.Self
;
193 if Init_Priority
= Unspecified_Priority
then
194 Init_Priority
:= System
.Priority
'Last;
197 if Locking_Policy
= 'C'
198 and then Has_Interrupt_Or_Attach_Handler
(Object
)
199 and then Init_Priority
not in System
.Interrupt_Priority
201 -- Required by C.3.1(11)
206 Initialization
.Defer_Abort
(Self_ID
);
207 Initialize_Lock
(Init_Priority
, Object
.L
'Access);
208 Initialization
.Undefer_Abort
(Self_ID
);
209 Object
.Ceiling
:= System
.Any_Priority
(Init_Priority
);
210 Object
.Owner
:= Null_Task
;
211 Object
.Compiler_Info
:= Compiler_Info
;
212 Object
.Pending_Action
:= False;
213 Object
.Call_In_Progress
:= null;
214 Object
.Entry_Bodies
:= Entry_Bodies
;
215 Object
.Find_Body_Index
:= Find_Body_Index
;
217 for E
in Object
.Entry_Queues
'Range loop
218 Object
.Entry_Queues
(E
).Head
:= null;
219 Object
.Entry_Queues
(E
).Tail
:= null;
221 end Initialize_Protection_Entries
;
227 procedure Lock_Entries
228 (Object
: Protection_Entries_Access
; Ceiling_Violation
: out Boolean)
231 if Object
.Finalized
then
233 (Program_Error
'Identity, "Protected Object is finalized");
236 -- If pragma Detect_Blocking is active then, as described in the ARM
237 -- 9.5.1, par. 15, we must check whether this is an external call on a
238 -- protected subprogram with the same target object as that of the
239 -- protected action that is currently in progress (i.e., if the caller
240 -- is already the protected object's owner). If this is the case hence
241 -- Program_Error must be raised.
243 if Detect_Blocking
and then Object
.Owner
= Self
then
247 -- The lock is made without defering abort
249 -- Therefore the abort has to be deferred before calling this routine.
250 -- This means that the compiler has to generate a Defer_Abort call
251 -- before the call to Lock.
253 -- The caller is responsible for undeferring abort, and compiler
254 -- generated calls must be protected with cleanup handlers to ensure
255 -- that abort is undeferred in all cases.
257 pragma Assert
(STPO
.Self
.Deferral_Level
> 0);
258 Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
260 -- We are entering in a protected action, so that we increase the
261 -- protected object nesting level (if pragma Detect_Blocking is
262 -- active), and update the protected object's owner.
264 if Detect_Blocking
then
266 Self_Id
: constant Task_Id
:= Self
;
269 -- Update the protected object's owner
271 Object
.Owner
:= Self_Id
;
273 -- Increase protected object nesting level
275 Self_Id
.Common
.Protected_Action_Nesting
:=
276 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
282 procedure Lock_Entries
(Object
: Protection_Entries_Access
) is
283 Ceiling_Violation
: Boolean;
286 Lock_Entries
(Object
, Ceiling_Violation
);
288 if Ceiling_Violation
then
289 Raise_Exception
(Program_Error
'Identity, "Ceiling Violation");
293 ----------------------------
294 -- Lock_Read_Only_Entries --
295 ----------------------------
297 procedure Lock_Read_Only_Entries
(Object
: Protection_Entries_Access
) is
298 Ceiling_Violation
: Boolean;
301 if Object
.Finalized
then
303 (Program_Error
'Identity, "Protected Object is finalized");
306 -- If pragma Detect_Blocking is active then, as described in the ARM
307 -- 9.5.1, par. 15, we must check whether this is an external call on a
308 -- protected subprogram with the same target object as that of the
309 -- protected action that is currently in progress (i.e., if the caller
310 -- is already the protected object's owner). If this is the case hence
311 -- Program_Error must be raised.
313 -- Note that in this case (getting read access), several tasks may
314 -- have read ownership of the protected object, so that this method of
315 -- storing the (single) protected object's owner does not work
316 -- reliably for read locks. However, this is the approach taken for two
317 -- major reasosn: first, this function is not currently being used (it
318 -- is provided for possible future use), and second, it largely
319 -- simplifies the implementation.
321 if Detect_Blocking
and then Object
.Owner
= Self
then
325 Read_Lock
(Object
.L
'Access, Ceiling_Violation
);
327 if Ceiling_Violation
then
328 Raise_Exception
(Program_Error
'Identity, "Ceiling Violation");
331 -- We are entering in a protected action, so that we increase the
332 -- protected object nesting level (if pragma Detect_Blocking is
333 -- active), and update the protected object's owner.
335 if Detect_Blocking
then
337 Self_Id
: constant Task_Id
:= Self
;
340 -- Update the protected object's owner
342 Object
.Owner
:= Self_Id
;
344 -- Increase protected object nesting level
346 Self_Id
.Common
.Protected_Action_Nesting
:=
347 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
350 end Lock_Read_Only_Entries
;
356 procedure Unlock_Entries
(Object
: Protection_Entries_Access
) is
358 -- We are exiting from a protected action, so that we decrease the
359 -- protected object nesting level (if pragma Detect_Blocking is
360 -- active), and remove ownership of the protected object.
362 if Detect_Blocking
then
364 Self_Id
: constant Task_Id
:= Self
;
367 -- Calls to this procedure can only take place when being within
368 -- a protected action and when the caller is the protected
371 pragma Assert
(Self_Id
.Common
.Protected_Action_Nesting
> 0
372 and then Object
.Owner
= Self_Id
);
374 -- Remove ownership of the protected object
376 Object
.Owner
:= Null_Task
;
378 Self_Id
.Common
.Protected_Action_Nesting
:=
379 Self_Id
.Common
.Protected_Action_Nesting
- 1;
383 Unlock
(Object
.L
'Access);
386 end System
.Tasking
.Protected_Objects
.Entries
;