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 --
9 -- Copyright (C) 1991-1994, Florida State University --
10 -- Copyright (C) 1995-2006, AdaCore --
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 ------------------------------------------------------------------------------
36 -- Turn off polling, we do not want ATC polling to take place during
37 -- tasking operations. It causes infinite loops and other problems.
39 with System
.Task_Primitives
.Operations
;
40 -- used for Write_Lock
45 with System
.Parameters
;
46 -- used for Runtime_Traces
49 -- used for Send_Trace_Info
51 with System
.Soft_Links
.Tasking
;
52 -- Used for Init_Tasking_Soft_Links
54 package body System
.Tasking
.Protected_Objects
is
56 use System
.Task_Primitives
.Operations
;
63 Locking_Policy
: Character;
64 pragma Import
(C
, Locking_Policy
, "__gl_locking_policy");
66 -------------------------
67 -- Finalize_Protection --
68 -------------------------
70 procedure Finalize_Protection
(Object
: in out Protection
) is
72 Finalize_Lock
(Object
.L
'Unrestricted_Access);
73 end Finalize_Protection
;
75 ---------------------------
76 -- Initialize_Protection --
77 ---------------------------
79 procedure Initialize_Protection
80 (Object
: Protection_Access
;
81 Ceiling_Priority
: Integer)
83 Init_Priority
: Integer := Ceiling_Priority
;
86 if Init_Priority
= Unspecified_Priority
then
87 Init_Priority
:= System
.Priority
'Last;
90 Initialize_Lock
(Init_Priority
, Object
.L
'Access);
91 Object
.Ceiling
:= System
.Any_Priority
(Init_Priority
);
92 Object
.New_Ceiling
:= System
.Any_Priority
(Init_Priority
);
93 Object
.Owner
:= Null_Task
;
94 end Initialize_Protection
;
101 (Object
: Protection_Access
) return System
.Any_Priority
is
103 return Object
.New_Ceiling
;
110 procedure Lock
(Object
: Protection_Access
) is
111 Ceiling_Violation
: Boolean;
114 -- The lock is made without defering abort
116 -- Therefore the abort has to be deferred before calling this routine.
117 -- This means that the compiler has to generate a Defer_Abort call
118 -- before the call to Lock.
120 -- The caller is responsible for undeferring abort, and compiler
121 -- generated calls must be protected with cleanup handlers to ensure
122 -- that abort is undeferred in all cases.
124 -- If pragma Detect_Blocking is active then, as described in the ARM
125 -- 9.5.1, par. 15, we must check whether this is an external call on a
126 -- protected subprogram with the same target object as that of the
127 -- protected action that is currently in progress (i.e., if the caller
128 -- is already the protected object's owner). If this is the case hence
129 -- Program_Error must be raised.
131 if Detect_Blocking
and then Object
.Owner
= Self
then
135 Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
137 if Parameters
.Runtime_Traces
then
138 Send_Trace_Info
(PO_Lock
);
141 if Ceiling_Violation
then
145 -- We are entering in a protected action, so that we increase the
146 -- protected object nesting level (if pragma Detect_Blocking is
147 -- active), and update the protected object's owner.
149 if Detect_Blocking
then
151 Self_Id
: constant Task_Id
:= Self
;
153 -- Update the protected object's owner
155 Object
.Owner
:= Self_Id
;
157 -- Increase protected object nesting level
159 Self_Id
.Common
.Protected_Action_Nesting
:=
160 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
169 procedure Lock_Read_Only
(Object
: Protection_Access
) is
170 Ceiling_Violation
: Boolean;
173 -- If pragma Detect_Blocking is active then, as described in the ARM
174 -- 9.5.1, par. 15, we must check whether this is an external call on
175 -- protected subprogram with the same target object as that of the
176 -- protected action that is currently in progress (i.e., if the caller
177 -- is already the protected object's owner). If this is the case hence
178 -- Program_Error must be raised.
180 -- Note that in this case (getting read access), several tasks may have
181 -- read ownership of the protected object, so that this method of
182 -- storing the (single) protected object's owner does not work reliably
183 -- for read locks. However, this is the approach taken for two major
184 -- reasosn: first, this function is not currently being used (it is
185 -- provided for possible future use), and second, it largely simplifies
186 -- the implementation.
188 if Detect_Blocking
and then Object
.Owner
= Self
then
192 Read_Lock
(Object
.L
'Access, Ceiling_Violation
);
194 if Parameters
.Runtime_Traces
then
195 Send_Trace_Info
(PO_Lock
);
198 if Ceiling_Violation
then
202 -- We are entering in a protected action, so we increase the protected
203 -- object nesting level (if pragma Detect_Blocking is active).
205 if Detect_Blocking
then
207 Self_Id
: constant Task_Id
:= Self
;
209 -- Update the protected object's owner
211 Object
.Owner
:= Self_Id
;
213 -- Increase protected object nesting level
215 Self_Id
.Common
.Protected_Action_Nesting
:=
216 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
225 procedure Set_Ceiling
226 (Object
: Protection_Access
;
227 Prio
: System
.Any_Priority
) is
229 Object
.New_Ceiling
:= Prio
;
236 procedure Unlock
(Object
: Protection_Access
) is
238 -- We are exiting from a protected action, so that we decrease the
239 -- protected object nesting level (if pragma Detect_Blocking is
240 -- active), and remove ownership of the protected object.
242 if Detect_Blocking
then
244 Self_Id
: constant Task_Id
:= Self
;
247 -- Calls to this procedure can only take place when being within
248 -- a protected action and when the caller is the protected
251 pragma Assert
(Self_Id
.Common
.Protected_Action_Nesting
> 0
252 and then Object
.Owner
= Self_Id
);
254 -- Remove ownership of the protected object
256 Object
.Owner
:= Null_Task
;
258 -- We are exiting from a protected action, so we decrease the
259 -- protected object nesting level.
261 Self_Id
.Common
.Protected_Action_Nesting
:=
262 Self_Id
.Common
.Protected_Action_Nesting
- 1;
266 -- Before releasing the mutex we must actually update its ceiling
267 -- priority if it has been changed.
269 if Object
.New_Ceiling
/= Object
.Ceiling
then
270 if Locking_Policy
= 'C' then
271 System
.Task_Primitives
.Operations
.Set_Ceiling
272 (Object
.L
'Access, Object
.New_Ceiling
);
275 Object
.Ceiling
:= Object
.New_Ceiling
;
278 Unlock
(Object
.L
'Access);
280 if Parameters
.Runtime_Traces
then
281 Send_Trace_Info
(PO_Unlock
);
286 -- Ensure that tasking is initialized, as well as tasking soft links
287 -- when using protected objects.
290 System
.Soft_Links
.Tasking
.Init_Tasking_Soft_Links
;
291 end System
.Tasking
.Protected_Objects
;