1 |
281 |
jeremybenn |
------------------------------------------------------------------------------
|
2 |
|
|
-- --
|
3 |
|
|
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
4 |
|
|
-- --
|
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 --
|
6 |
|
|
-- --
|
7 |
|
|
-- B o d y --
|
8 |
|
|
-- --
|
9 |
|
|
-- Copyright (C) 1991-1994, Florida State University --
|
10 |
|
|
-- Copyright (C) 1995-2008, AdaCore --
|
11 |
|
|
-- --
|
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. --
|
22 |
|
|
-- --
|
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. --
|
29 |
|
|
-- --
|
30 |
|
|
-- GNARL was developed by the GNARL team at Florida State University. --
|
31 |
|
|
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
|
32 |
|
|
-- --
|
33 |
|
|
------------------------------------------------------------------------------
|
34 |
|
|
|
35 |
|
|
pragma Polling (Off);
|
36 |
|
|
-- Turn off polling, we do not want ATC polling to take place during
|
37 |
|
|
-- tasking operations. It causes infinite loops and other problems.
|
38 |
|
|
|
39 |
|
|
with System.Task_Primitives.Operations;
|
40 |
|
|
with System.Parameters;
|
41 |
|
|
with System.Traces;
|
42 |
|
|
with System.Soft_Links.Tasking;
|
43 |
|
|
|
44 |
|
|
package body System.Tasking.Protected_Objects is
|
45 |
|
|
|
46 |
|
|
use System.Task_Primitives.Operations;
|
47 |
|
|
use System.Traces;
|
48 |
|
|
|
49 |
|
|
----------------
|
50 |
|
|
-- Local Data --
|
51 |
|
|
----------------
|
52 |
|
|
|
53 |
|
|
Locking_Policy : Character;
|
54 |
|
|
pragma Import (C, Locking_Policy, "__gl_locking_policy");
|
55 |
|
|
|
56 |
|
|
-------------------------
|
57 |
|
|
-- Finalize_Protection --
|
58 |
|
|
-------------------------
|
59 |
|
|
|
60 |
|
|
procedure Finalize_Protection (Object : in out Protection) is
|
61 |
|
|
begin
|
62 |
|
|
Finalize_Lock (Object.L'Unrestricted_Access);
|
63 |
|
|
end Finalize_Protection;
|
64 |
|
|
|
65 |
|
|
---------------------------
|
66 |
|
|
-- Initialize_Protection --
|
67 |
|
|
---------------------------
|
68 |
|
|
|
69 |
|
|
procedure Initialize_Protection
|
70 |
|
|
(Object : Protection_Access;
|
71 |
|
|
Ceiling_Priority : Integer)
|
72 |
|
|
is
|
73 |
|
|
Init_Priority : Integer := Ceiling_Priority;
|
74 |
|
|
|
75 |
|
|
begin
|
76 |
|
|
if Init_Priority = Unspecified_Priority then
|
77 |
|
|
Init_Priority := System.Priority'Last;
|
78 |
|
|
end if;
|
79 |
|
|
|
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;
|
85 |
|
|
|
86 |
|
|
-----------------
|
87 |
|
|
-- Get_Ceiling --
|
88 |
|
|
-----------------
|
89 |
|
|
|
90 |
|
|
function Get_Ceiling
|
91 |
|
|
(Object : Protection_Access) return System.Any_Priority is
|
92 |
|
|
begin
|
93 |
|
|
return Object.New_Ceiling;
|
94 |
|
|
end Get_Ceiling;
|
95 |
|
|
|
96 |
|
|
----------
|
97 |
|
|
-- Lock --
|
98 |
|
|
----------
|
99 |
|
|
|
100 |
|
|
procedure Lock (Object : Protection_Access) is
|
101 |
|
|
Ceiling_Violation : Boolean;
|
102 |
|
|
|
103 |
|
|
begin
|
104 |
|
|
-- The lock is made without deferring abort
|
105 |
|
|
|
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.
|
109 |
|
|
|
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.
|
113 |
|
|
|
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.
|
120 |
|
|
|
121 |
|
|
if Detect_Blocking and then Object.Owner = Self then
|
122 |
|
|
raise Program_Error;
|
123 |
|
|
end if;
|
124 |
|
|
|
125 |
|
|
Write_Lock (Object.L'Access, Ceiling_Violation);
|
126 |
|
|
|
127 |
|
|
if Parameters.Runtime_Traces then
|
128 |
|
|
Send_Trace_Info (PO_Lock);
|
129 |
|
|
end if;
|
130 |
|
|
|
131 |
|
|
if Ceiling_Violation then
|
132 |
|
|
raise Program_Error;
|
133 |
|
|
end if;
|
134 |
|
|
|
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.
|
138 |
|
|
|
139 |
|
|
if Detect_Blocking then
|
140 |
|
|
declare
|
141 |
|
|
Self_Id : constant Task_Id := Self;
|
142 |
|
|
begin
|
143 |
|
|
-- Update the protected object's owner
|
144 |
|
|
|
145 |
|
|
Object.Owner := Self_Id;
|
146 |
|
|
|
147 |
|
|
-- Increase protected object nesting level
|
148 |
|
|
|
149 |
|
|
Self_Id.Common.Protected_Action_Nesting :=
|
150 |
|
|
Self_Id.Common.Protected_Action_Nesting + 1;
|
151 |
|
|
end;
|
152 |
|
|
end if;
|
153 |
|
|
end Lock;
|
154 |
|
|
|
155 |
|
|
--------------------
|
156 |
|
|
-- Lock_Read_Only --
|
157 |
|
|
--------------------
|
158 |
|
|
|
159 |
|
|
procedure Lock_Read_Only (Object : Protection_Access) is
|
160 |
|
|
Ceiling_Violation : Boolean;
|
161 |
|
|
|
162 |
|
|
begin
|
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.
|
169 |
|
|
--
|
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.
|
177 |
|
|
|
178 |
|
|
if Detect_Blocking and then Object.Owner = Self then
|
179 |
|
|
raise Program_Error;
|
180 |
|
|
end if;
|
181 |
|
|
|
182 |
|
|
Read_Lock (Object.L'Access, Ceiling_Violation);
|
183 |
|
|
|
184 |
|
|
if Parameters.Runtime_Traces then
|
185 |
|
|
Send_Trace_Info (PO_Lock);
|
186 |
|
|
end if;
|
187 |
|
|
|
188 |
|
|
if Ceiling_Violation then
|
189 |
|
|
raise Program_Error;
|
190 |
|
|
end if;
|
191 |
|
|
|
192 |
|
|
-- We are entering in a protected action, so we increase the protected
|
193 |
|
|
-- object nesting level (if pragma Detect_Blocking is active).
|
194 |
|
|
|
195 |
|
|
if Detect_Blocking then
|
196 |
|
|
declare
|
197 |
|
|
Self_Id : constant Task_Id := Self;
|
198 |
|
|
begin
|
199 |
|
|
-- Update the protected object's owner
|
200 |
|
|
|
201 |
|
|
Object.Owner := Self_Id;
|
202 |
|
|
|
203 |
|
|
-- Increase protected object nesting level
|
204 |
|
|
|
205 |
|
|
Self_Id.Common.Protected_Action_Nesting :=
|
206 |
|
|
Self_Id.Common.Protected_Action_Nesting + 1;
|
207 |
|
|
end;
|
208 |
|
|
end if;
|
209 |
|
|
end Lock_Read_Only;
|
210 |
|
|
|
211 |
|
|
-----------------
|
212 |
|
|
-- Set_Ceiling --
|
213 |
|
|
-----------------
|
214 |
|
|
|
215 |
|
|
procedure Set_Ceiling
|
216 |
|
|
(Object : Protection_Access;
|
217 |
|
|
Prio : System.Any_Priority) is
|
218 |
|
|
begin
|
219 |
|
|
Object.New_Ceiling := Prio;
|
220 |
|
|
end Set_Ceiling;
|
221 |
|
|
|
222 |
|
|
------------
|
223 |
|
|
-- Unlock --
|
224 |
|
|
------------
|
225 |
|
|
|
226 |
|
|
procedure Unlock (Object : Protection_Access) is
|
227 |
|
|
begin
|
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.
|
231 |
|
|
|
232 |
|
|
if Detect_Blocking then
|
233 |
|
|
declare
|
234 |
|
|
Self_Id : constant Task_Id := Self;
|
235 |
|
|
|
236 |
|
|
begin
|
237 |
|
|
-- Calls to this procedure can only take place when being within
|
238 |
|
|
-- a protected action and when the caller is the protected
|
239 |
|
|
-- object's owner.
|
240 |
|
|
|
241 |
|
|
pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
|
242 |
|
|
and then Object.Owner = Self_Id);
|
243 |
|
|
|
244 |
|
|
-- Remove ownership of the protected object
|
245 |
|
|
|
246 |
|
|
Object.Owner := Null_Task;
|
247 |
|
|
|
248 |
|
|
-- We are exiting from a protected action, so we decrease the
|
249 |
|
|
-- protected object nesting level.
|
250 |
|
|
|
251 |
|
|
Self_Id.Common.Protected_Action_Nesting :=
|
252 |
|
|
Self_Id.Common.Protected_Action_Nesting - 1;
|
253 |
|
|
end;
|
254 |
|
|
end if;
|
255 |
|
|
|
256 |
|
|
-- Before releasing the mutex we must actually update its ceiling
|
257 |
|
|
-- priority if it has been changed.
|
258 |
|
|
|
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);
|
263 |
|
|
end if;
|
264 |
|
|
|
265 |
|
|
Object.Ceiling := Object.New_Ceiling;
|
266 |
|
|
end if;
|
267 |
|
|
|
268 |
|
|
Unlock (Object.L'Access);
|
269 |
|
|
|
270 |
|
|
if Parameters.Runtime_Traces then
|
271 |
|
|
Send_Trace_Info (PO_Unlock);
|
272 |
|
|
end if;
|
273 |
|
|
end Unlock;
|
274 |
|
|
|
275 |
|
|
begin
|
276 |
|
|
-- Ensure that tasking is initialized, as well as tasking soft links
|
277 |
|
|
-- when using protected objects.
|
278 |
|
|
|
279 |
|
|
Tasking.Initialize;
|
280 |
|
|
System.Soft_Links.Tasking.Init_Tasking_Soft_Links;
|
281 |
|
|
end System.Tasking.Protected_Objects;
|