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-2008, 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 with System.Parameters;
42 with System.Soft_Links.Tasking;
44 package body System.Tasking.Protected_Objects is
46 use System.Task_Primitives.Operations;
53 Locking_Policy : Character;
54 pragma Import (C, Locking_Policy, "__gl_locking_policy");
56 -------------------------
57 -- Finalize_Protection --
58 -------------------------
60 procedure Finalize_Protection (Object : in out Protection) is
62 Finalize_Lock (Object.L'Unrestricted_Access);
63 end Finalize_Protection;
65 ---------------------------
66 -- Initialize_Protection --
67 ---------------------------
69 procedure Initialize_Protection
70 (Object : Protection_Access;
71 Ceiling_Priority : Integer)
73 Init_Priority : Integer := Ceiling_Priority;
76 if Init_Priority = Unspecified_Priority then
77 Init_Priority := System.Priority'Last;
80 Initialize_Lock (Init_Priority, Object.L'Access);
81 Object.Ceiling := System.Any_Priority (Init_Priority);
82 Object.New_Ceiling := System.Any_Priority (Init_Priority);
83 Object.Owner := Null_Task;
84 end Initialize_Protection;
91 (Object : Protection_Access) return System.Any_Priority is
93 return Object.New_Ceiling;
100 procedure Lock (Object : Protection_Access) is
101 Ceiling_Violation : Boolean;
104 -- The lock is made without deferring abort
106 -- Therefore the abort has to be deferred before calling this routine.
107 -- This means that the compiler has to generate a Defer_Abort call
108 -- before the call to Lock.
110 -- The caller is responsible for undeferring abort, and compiler
111 -- generated calls must be protected with cleanup handlers to ensure
112 -- that abort is undeferred in all cases.
114 -- If pragma Detect_Blocking is active then, as described in the ARM
115 -- 9.5.1, par. 15, we must check whether this is an external call on a
116 -- protected subprogram with the same target object as that of the
117 -- protected action that is currently in progress (i.e., if the caller
118 -- is already the protected object's owner). If this is the case hence
119 -- Program_Error must be raised.
121 if Detect_Blocking and then Object.Owner = Self then
125 Write_Lock (Object.L'Access, Ceiling_Violation);
127 if Parameters.Runtime_Traces then
128 Send_Trace_Info (PO_Lock);
131 if Ceiling_Violation then
135 -- We are entering in a protected action, so that we increase the
136 -- protected object nesting level (if pragma Detect_Blocking is
137 -- active), and update the protected object's owner.
139 if Detect_Blocking then
141 Self_Id : constant Task_Id := Self;
143 -- Update the protected object's owner
145 Object.Owner := Self_Id;
147 -- Increase protected object nesting level
149 Self_Id.Common.Protected_Action_Nesting :=
150 Self_Id.Common.Protected_Action_Nesting + 1;
159 procedure Lock_Read_Only (Object : Protection_Access) is
160 Ceiling_Violation : Boolean;
163 -- If pragma Detect_Blocking is active then, as described in the ARM
164 -- 9.5.1, par. 15, we must check whether this is an external call on
165 -- protected subprogram with the same target object as that of the
166 -- protected action that is currently in progress (i.e., if the caller
167 -- is already the protected object's owner). If this is the case hence
168 -- Program_Error must be raised.
170 -- Note that in this case (getting read access), several tasks may have
171 -- read ownership of the protected object, so that this method of
172 -- storing the (single) protected object's owner does not work reliably
173 -- for read locks. However, this is the approach taken for two major
174 -- reasons: first, this function is not currently being used (it is
175 -- provided for possible future use), and second, it largely simplifies
176 -- the implementation.
178 if Detect_Blocking and then Object.Owner = Self then
182 Read_Lock (Object.L'Access, Ceiling_Violation);
184 if Parameters.Runtime_Traces then
185 Send_Trace_Info (PO_Lock);
188 if Ceiling_Violation then
192 -- We are entering in a protected action, so we increase the protected
193 -- object nesting level (if pragma Detect_Blocking is active).
195 if Detect_Blocking then
197 Self_Id : constant Task_Id := Self;
199 -- Update the protected object's owner
201 Object.Owner := Self_Id;
203 -- Increase protected object nesting level
205 Self_Id.Common.Protected_Action_Nesting :=
206 Self_Id.Common.Protected_Action_Nesting + 1;
215 procedure Set_Ceiling
216 (Object : Protection_Access;
217 Prio : System.Any_Priority) is
219 Object.New_Ceiling := Prio;
226 procedure Unlock (Object : Protection_Access) is
228 -- We are exiting from a protected action, so that we decrease the
229 -- protected object nesting level (if pragma Detect_Blocking is
230 -- active), and remove ownership of the protected object.
232 if Detect_Blocking then
234 Self_Id : constant Task_Id := Self;
237 -- Calls to this procedure can only take place when being within
238 -- a protected action and when the caller is the protected
241 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
242 and then Object.Owner = Self_Id);
244 -- Remove ownership of the protected object
246 Object.Owner := Null_Task;
248 -- We are exiting from a protected action, so we decrease the
249 -- protected object nesting level.
251 Self_Id.Common.Protected_Action_Nesting :=
252 Self_Id.Common.Protected_Action_Nesting - 1;
256 -- Before releasing the mutex we must actually update its ceiling
257 -- priority if it has been changed.
259 if Object.New_Ceiling /= Object.Ceiling then
260 if Locking_Policy = 'C' then
261 System.Task_Primitives.Operations.Set_Ceiling
262 (Object.L'Access, Object.New_Ceiling);
265 Object.Ceiling := Object.New_Ceiling;
268 Unlock (Object.L'Access);
270 if Parameters.Runtime_Traces then
271 Send_Trace_Info (PO_Unlock);
276 -- Ensure that tasking is initialized, as well as tasking soft links
277 -- when using protected objects.
280 System.Soft_Links.Tasking.Init_Tasking_Soft_Links;
281 end System.Tasking.Protected_Objects;