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-2011, AdaCore --
12 -- GNAT 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 3, or (at your option) any later ver- --
15 -- sion. GNAT 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. --
19 -- As a special exception under Section 7 of GPL version 3, you are granted --
20 -- additional permissions described in the GCC Runtime Library Exception, --
21 -- version 3.1, as published by the Free Software Foundation. --
23 -- You should have received a copy of the GNU General Public License and --
24 -- a copy of the GCC Runtime Library Exception along with this program; --
25 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
26 -- <http://www.gnu.org/licenses/>. --
28 -- GNARL was developed by the GNARL team at Florida State University. --
29 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
31 ------------------------------------------------------------------------------
34 -- Turn off polling, we do not want ATC polling to take place during
35 -- tasking operations. It causes infinite loops and other problems.
37 with System.Task_Primitives.Operations;
38 with System.Parameters;
40 with System.Soft_Links.Tasking;
42 package body System.Tasking.Protected_Objects is
44 use System.Task_Primitives.Operations;
51 Locking_Policy : Character;
52 pragma Import (C, Locking_Policy, "__gl_locking_policy");
54 -------------------------
55 -- Finalize_Protection --
56 -------------------------
58 procedure Finalize_Protection (Object : in out Protection) is
60 Finalize_Lock (Object.L'Unrestricted_Access);
61 end Finalize_Protection;
63 ---------------------------
64 -- Initialize_Protection --
65 ---------------------------
67 procedure Initialize_Protection
68 (Object : Protection_Access;
69 Ceiling_Priority : Integer)
71 Init_Priority : Integer := Ceiling_Priority;
74 if Init_Priority = Unspecified_Priority then
75 Init_Priority := System.Priority'Last;
78 Initialize_Lock (Init_Priority, Object.L'Access);
79 Object.Ceiling := System.Any_Priority (Init_Priority);
80 Object.New_Ceiling := System.Any_Priority (Init_Priority);
81 Object.Owner := Null_Task;
82 end Initialize_Protection;
89 (Object : Protection_Access) return System.Any_Priority is
91 return Object.New_Ceiling;
98 procedure Lock (Object : Protection_Access) is
99 Ceiling_Violation : Boolean;
102 -- The lock is made without deferring abort
104 -- Therefore the abort has to be deferred before calling this routine.
105 -- This means that the compiler has to generate a Defer_Abort call
106 -- before the call to Lock.
108 -- The caller is responsible for undeferring abort, and compiler
109 -- generated calls must be protected with cleanup handlers to ensure
110 -- that abort is undeferred in all cases.
112 -- If pragma Detect_Blocking is active then, as described in the ARM
113 -- 9.5.1, par. 15, we must check whether this is an external call on a
114 -- protected subprogram with the same target object as that of the
115 -- protected action that is currently in progress (i.e., if the caller
116 -- is already the protected object's owner). If this is the case hence
117 -- Program_Error must be raised.
119 if Detect_Blocking and then Object.Owner = Self then
123 Write_Lock (Object.L'Access, Ceiling_Violation);
125 if Parameters.Runtime_Traces then
126 Send_Trace_Info (PO_Lock);
129 if Ceiling_Violation then
133 -- We are entering in a protected action, so that we increase the
134 -- protected object nesting level (if pragma Detect_Blocking is
135 -- active), and update the protected object's owner.
137 if Detect_Blocking then
139 Self_Id : constant Task_Id := Self;
141 -- Update the protected object's owner
143 Object.Owner := Self_Id;
145 -- Increase protected object nesting level
147 Self_Id.Common.Protected_Action_Nesting :=
148 Self_Id.Common.Protected_Action_Nesting + 1;
157 procedure Lock_Read_Only (Object : Protection_Access) is
158 Ceiling_Violation : Boolean;
161 -- If pragma Detect_Blocking is active then, as described in the ARM
162 -- 9.5.1, par. 15, we must check whether this is an external call on
163 -- protected subprogram with the same target object as that of the
164 -- protected action that is currently in progress (i.e., if the caller
165 -- is already the protected object's owner). If this is the case hence
166 -- Program_Error must be raised.
168 -- Note that in this case (getting read access), several tasks may have
169 -- read ownership of the protected object, so that this method of
170 -- storing the (single) protected object's owner does not work reliably
171 -- for read locks. However, this is the approach taken for two major
172 -- reasons: first, this function is not currently being used (it is
173 -- provided for possible future use), and second, it largely simplifies
174 -- the implementation.
176 if Detect_Blocking and then Object.Owner = Self then
180 Read_Lock (Object.L'Access, Ceiling_Violation);
182 if Parameters.Runtime_Traces then
183 Send_Trace_Info (PO_Lock);
186 if Ceiling_Violation then
190 -- We are entering in a protected action, so we increase the protected
191 -- object nesting level (if pragma Detect_Blocking is active).
193 if Detect_Blocking then
195 Self_Id : constant Task_Id := Self;
197 -- Update the protected object's owner
199 Object.Owner := Self_Id;
201 -- Increase protected object nesting level
203 Self_Id.Common.Protected_Action_Nesting :=
204 Self_Id.Common.Protected_Action_Nesting + 1;
213 procedure Set_Ceiling
214 (Object : Protection_Access;
215 Prio : System.Any_Priority) is
217 Object.New_Ceiling := Prio;
224 procedure Unlock (Object : Protection_Access) is
226 -- We are exiting from a protected action, so that we decrease the
227 -- protected object nesting level (if pragma Detect_Blocking is
228 -- active), and remove ownership of the protected object.
230 if Detect_Blocking then
232 Self_Id : constant Task_Id := Self;
235 -- Calls to this procedure can only take place when being within
236 -- a protected action and when the caller is the protected
239 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
240 and then Object.Owner = Self_Id);
242 -- Remove ownership of the protected object
244 Object.Owner := Null_Task;
246 -- We are exiting from a protected action, so we decrease the
247 -- protected object nesting level.
249 Self_Id.Common.Protected_Action_Nesting :=
250 Self_Id.Common.Protected_Action_Nesting - 1;
254 -- Before releasing the mutex we must actually update its ceiling
255 -- priority if it has been changed.
257 if Object.New_Ceiling /= Object.Ceiling then
258 if Locking_Policy = 'C' then
259 System.Task_Primitives.Operations.Set_Ceiling
260 (Object.L'Access, Object.New_Ceiling);
263 Object.Ceiling := Object.New_Ceiling;
266 Unlock (Object.L'Access);
268 if Parameters.Runtime_Traces then
269 Send_Trace_Info (PO_Unlock);
274 -- Ensure that tasking is initialized, as well as tasking soft links
275 -- when using protected objects.
278 System.Soft_Links.Tasking.Init_Tasking_Soft_Links;
279 end System.Tasking.Protected_Objects;