1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
|
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- 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 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2010, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with System.Task_Primitives.Operations;
with System.Parameters;
with System.Traces;
with System.Soft_Links.Tasking;
package body System.Tasking.Protected_Objects is
use System.Task_Primitives.Operations;
use System.Traces;
----------------
-- Local Data --
----------------
Locking_Policy : Character;
pragma Import (C, Locking_Policy, "__gl_locking_policy");
-------------------------
-- Finalize_Protection --
-------------------------
procedure Finalize_Protection (Object : in out Protection) is
begin
Finalize_Lock (Object.L'Unrestricted_Access);
end Finalize_Protection;
---------------------------
-- Initialize_Protection --
---------------------------
procedure Initialize_Protection
(Object : Protection_Access;
Ceiling_Priority : Integer)
is
Init_Priority : Integer := Ceiling_Priority;
begin
if Init_Priority = Unspecified_Priority then
Init_Priority := System.Priority'Last;
end if;
Initialize_Lock (Init_Priority, Object.L'Access);
Object.Ceiling := System.Any_Priority (Init_Priority);
Object.New_Ceiling := System.Any_Priority (Init_Priority);
Object.Owner := Null_Task;
end Initialize_Protection;
-----------------
-- Get_Ceiling --
-----------------
function Get_Ceiling
(Object : Protection_Access) return System.Any_Priority is
begin
return Object.New_Ceiling;
end Get_Ceiling;
----------
-- Lock --
----------
procedure Lock (Object : Protection_Access) is
Ceiling_Violation : Boolean;
begin
-- The lock is made without deferring abort
-- Therefore the abort has to be deferred before calling this routine.
-- This means that the compiler has to generate a Defer_Abort call
-- before the call to Lock.
-- The caller is responsible for undeferring abort, and compiler
-- generated calls must be protected with cleanup handlers to ensure
-- that abort is undeferred in all cases.
-- If pragma Detect_Blocking is active then, as described in the ARM
-- 9.5.1, par. 15, we must check whether this is an external call on a
-- protected subprogram with the same target object as that of the
-- protected action that is currently in progress (i.e., if the caller
-- is already the protected object's owner). If this is the case hence
-- Program_Error must be raised.
if Detect_Blocking and then Object.Owner = Self then
raise Program_Error;
end if;
Write_Lock (Object.L'Access, Ceiling_Violation);
if Parameters.Runtime_Traces then
Send_Trace_Info (PO_Lock);
end if;
if Ceiling_Violation then
raise Program_Error;
end if;
-- We are entering in a protected action, so that we increase the
-- protected object nesting level (if pragma Detect_Blocking is
-- active), and update the protected object's owner.
if Detect_Blocking then
declare
Self_Id : constant Task_Id := Self;
begin
-- Update the protected object's owner
Object.Owner := Self_Id;
-- Increase protected object nesting level
Self_Id.Common.Protected_Action_Nesting :=
Self_Id.Common.Protected_Action_Nesting + 1;
end;
end if;
end Lock;
--------------------
-- Lock_Read_Only --
--------------------
procedure Lock_Read_Only (Object : Protection_Access) is
Ceiling_Violation : Boolean;
begin
-- If pragma Detect_Blocking is active then, as described in the ARM
-- 9.5.1, par. 15, we must check whether this is an external call on
-- protected subprogram with the same target object as that of the
-- protected action that is currently in progress (i.e., if the caller
-- is already the protected object's owner). If this is the case hence
-- Program_Error must be raised.
--
-- Note that in this case (getting read access), several tasks may have
-- read ownership of the protected object, so that this method of
-- storing the (single) protected object's owner does not work reliably
-- for read locks. However, this is the approach taken for two major
-- reasons: first, this function is not currently being used (it is
-- provided for possible future use), and second, it largely simplifies
-- the implementation.
if Detect_Blocking and then Object.Owner = Self then
raise Program_Error;
end if;
Read_Lock (Object.L'Access, Ceiling_Violation);
if Parameters.Runtime_Traces then
Send_Trace_Info (PO_Lock);
end if;
if Ceiling_Violation then
raise Program_Error;
end if;
-- We are entering in a protected action, so we increase the protected
-- object nesting level (if pragma Detect_Blocking is active).
if Detect_Blocking then
declare
Self_Id : constant Task_Id := Self;
begin
-- Update the protected object's owner
Object.Owner := Self_Id;
-- Increase protected object nesting level
Self_Id.Common.Protected_Action_Nesting :=
Self_Id.Common.Protected_Action_Nesting + 1;
end;
end if;
end Lock_Read_Only;
-----------------
-- Set_Ceiling --
-----------------
procedure Set_Ceiling
(Object : Protection_Access;
Prio : System.Any_Priority) is
begin
Object.New_Ceiling := Prio;
end Set_Ceiling;
------------
-- Unlock --
------------
procedure Unlock (Object : Protection_Access) is
begin
-- We are exiting from a protected action, so that we decrease the
-- protected object nesting level (if pragma Detect_Blocking is
-- active), and remove ownership of the protected object.
if Detect_Blocking then
declare
Self_Id : constant Task_Id := Self;
begin
-- Calls to this procedure can only take place when being within
-- a protected action and when the caller is the protected
-- object's owner.
pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
and then Object.Owner = Self_Id);
-- Remove ownership of the protected object
Object.Owner := Null_Task;
-- We are exiting from a protected action, so we decrease the
-- protected object nesting level.
Self_Id.Common.Protected_Action_Nesting :=
Self_Id.Common.Protected_Action_Nesting - 1;
end;
end if;
-- Before releasing the mutex we must actually update its ceiling
-- priority if it has been changed.
if Object.New_Ceiling /= Object.Ceiling then
if Locking_Policy = 'C' then
System.Task_Primitives.Operations.Set_Ceiling
(Object.L'Access, Object.New_Ceiling);
end if;
Object.Ceiling := Object.New_Ceiling;
end if;
Unlock (Object.L'Access);
if Parameters.Runtime_Traces then
Send_Trace_Info (PO_Unlock);
end if;
end Unlock;
begin
-- Ensure that tasking is initialized, as well as tasking soft links
-- when using protected objects.
Tasking.Initialize;
System.Soft_Links.Tasking.Init_Tasking_Soft_Links;
end System.Tasking.Protected_Objects;
|
