File : s-tpoben.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
10 -- --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This package contains all the simple primitives related to protected
33 -- objects with entries (i.e init, lock, unlock).
34
35 -- The handling of protected objects with no entries is done in
36 -- System.Tasking.Protected_Objects, the complex routines for protected
37 -- objects with entries in System.Tasking.Protected_Objects.Operations.
38
39 -- The split between Entries and Operations is needed to break circular
40 -- dependencies inside the run time.
41
42 -- Note: the compiler generates direct calls to this interface, via Rtsfind
43
44 with System.Task_Primitives.Operations;
45 with System.Restrictions;
46 with System.Parameters;
47
48 with System.Tasking.Initialization;
49 pragma Elaborate_All (System.Tasking.Initialization);
50 -- To insure that tasking is initialized if any protected objects are created
51
52 package body System.Tasking.Protected_Objects.Entries is
53
54 package STPO renames System.Task_Primitives.Operations;
55
56 use Parameters;
57 use Task_Primitives.Operations;
58
59 ----------------
60 -- Local Data --
61 ----------------
62
63 Locking_Policy : Character;
64 pragma Import (C, Locking_Policy, "__gl_locking_policy");
65
66 --------------
67 -- Finalize --
68 --------------
69
70 overriding procedure Finalize (Object : in out Protection_Entries) is
71 Entry_Call : Entry_Call_Link;
72 Caller : Task_Id;
73 Ceiling_Violation : Boolean;
74 Self_ID : constant Task_Id := STPO.Self;
75 Old_Base_Priority : System.Any_Priority;
76
77 begin
78 if Object.Finalized then
79 return;
80 end if;
81
82 STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
83
84 if Single_Lock then
85 Lock_RTS;
86 end if;
87
88 if Ceiling_Violation then
89
90 -- Dip our own priority down to ceiling of lock. See similar code in
91 -- Tasking.Entry_Calls.Lock_Server.
92
93 STPO.Write_Lock (Self_ID);
94 Old_Base_Priority := Self_ID.Common.Base_Priority;
95 Self_ID.New_Base_Priority := Object.Ceiling;
96 Initialization.Change_Base_Priority (Self_ID);
97 STPO.Unlock (Self_ID);
98
99 if Single_Lock then
100 Unlock_RTS;
101 end if;
102
103 STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
104
105 if Ceiling_Violation then
106 raise Program_Error with "ceiling violation";
107 end if;
108
109 if Single_Lock then
110 Lock_RTS;
111 end if;
112
113 Object.Old_Base_Priority := Old_Base_Priority;
114 Object.Pending_Action := True;
115 end if;
116
117 -- Send program_error to all tasks still queued on this object
118
119 for E in Object.Entry_Queues'Range loop
120 Entry_Call := Object.Entry_Queues (E).Head;
121
122 while Entry_Call /= null loop
123 Caller := Entry_Call.Self;
124 Entry_Call.Exception_To_Raise := Program_Error'Identity;
125
126 STPO.Write_Lock (Caller);
127 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
128 STPO.Unlock (Caller);
129
130 exit when Entry_Call = Object.Entry_Queues (E).Tail;
131 Entry_Call := Entry_Call.Next;
132 end loop;
133 end loop;
134
135 Object.Finalized := True;
136
137 if Single_Lock then
138 Unlock_RTS;
139 end if;
140
141 STPO.Unlock (Object.L'Unrestricted_Access);
142
143 STPO.Finalize_Lock (Object.L'Unrestricted_Access);
144 end Finalize;
145
146 -----------------
147 -- Get_Ceiling --
148 -----------------
149
150 function Get_Ceiling
151 (Object : Protection_Entries_Access) return System.Any_Priority is
152 begin
153 return Object.New_Ceiling;
154 end Get_Ceiling;
155
156 -------------------------------------
157 -- Has_Interrupt_Or_Attach_Handler --
158 -------------------------------------
159
160 function Has_Interrupt_Or_Attach_Handler
161 (Object : Protection_Entries_Access)
162 return Boolean
163 is
164 pragma Warnings (Off, Object);
165 begin
166 return False;
167 end Has_Interrupt_Or_Attach_Handler;
168
169 -----------------------------------
170 -- Initialize_Protection_Entries --
171 -----------------------------------
172
173 procedure Initialize_Protection_Entries
174 (Object : Protection_Entries_Access;
175 Ceiling_Priority : Integer;
176 Compiler_Info : System.Address;
177 Entry_Bodies : Protected_Entry_Body_Access;
178 Find_Body_Index : Find_Body_Index_Access)
179 is
180 Init_Priority : Integer := Ceiling_Priority;
181 Self_ID : constant Task_Id := STPO.Self;
182
183 begin
184 if Init_Priority = Unspecified_Priority then
185 Init_Priority := System.Priority'Last;
186 end if;
187
188 if Locking_Policy = 'C'
189 and then Has_Interrupt_Or_Attach_Handler (Object)
190 and then Init_Priority not in System.Interrupt_Priority
191 then
192 -- Required by C.3.1(11)
193
194 raise Program_Error;
195 end if;
196
197 -- If a PO is created from a controlled operation, abort is already
198 -- deferred at this point, so we need to use Defer_Abort_Nestable. In
199 -- some cases, the following assertion can help to spot inconsistencies,
200 -- outside the above scenario involving controlled types.
201
202 -- pragma Assert (Self_Id.Deferral_Level = 0);
203
204 Initialization.Defer_Abort_Nestable (Self_ID);
205 Initialize_Lock (Init_Priority, Object.L'Access);
206 Initialization.Undefer_Abort_Nestable (Self_ID);
207
208 Object.Ceiling := System.Any_Priority (Init_Priority);
209 Object.New_Ceiling := System.Any_Priority (Init_Priority);
210 Object.Owner := Null_Task;
211 Object.Compiler_Info := Compiler_Info;
212 Object.Pending_Action := False;
213 Object.Call_In_Progress := null;
214 Object.Entry_Bodies := Entry_Bodies;
215 Object.Find_Body_Index := Find_Body_Index;
216
217 for E in Object.Entry_Queues'Range loop
218 Object.Entry_Queues (E).Head := null;
219 Object.Entry_Queues (E).Tail := null;
220 end loop;
221 end Initialize_Protection_Entries;
222
223 ------------------
224 -- Lock_Entries --
225 ------------------
226
227 procedure Lock_Entries (Object : Protection_Entries_Access) is
228 Ceiling_Violation : Boolean;
229
230 begin
231 Lock_Entries_With_Status (Object, Ceiling_Violation);
232
233 if Ceiling_Violation then
234 raise Program_Error with "ceiling violation";
235 end if;
236 end Lock_Entries;
237
238 ------------------------------
239 -- Lock_Entries_With_Status --
240 ------------------------------
241
242 procedure Lock_Entries_With_Status
243 (Object : Protection_Entries_Access;
244 Ceiling_Violation : out Boolean)
245 is
246 begin
247 if Object.Finalized then
248 raise Program_Error with "protected object is finalized";
249 end if;
250
251 -- If pragma Detect_Blocking is active then, as described in the ARM
252 -- 9.5.1, par. 15, we must check whether this is an external call on a
253 -- protected subprogram with the same target object as that of the
254 -- protected action that is currently in progress (i.e., if the caller
255 -- is already the protected object's owner). If this is the case hence
256 -- Program_Error must be raised.
257
258 if Detect_Blocking and then Object.Owner = Self then
259 raise Program_Error;
260 end if;
261
262 -- The lock is made without deferring abort
263
264 -- Therefore the abort has to be deferred before calling this routine.
265 -- This means that the compiler has to generate a Defer_Abort call
266 -- before the call to Lock.
267
268 -- The caller is responsible for undeferring abort, and compiler
269 -- generated calls must be protected with cleanup handlers to ensure
270 -- that abort is undeferred in all cases.
271
272 pragma Assert
273 (STPO.Self.Deferral_Level > 0
274 or else not Restrictions.Abort_Allowed);
275
276 Write_Lock (Object.L'Access, Ceiling_Violation);
277
278 -- We are entering in a protected action, so that we increase the
279 -- protected object nesting level (if pragma Detect_Blocking is
280 -- active), and update the protected object's owner.
281
282 if Detect_Blocking then
283 declare
284 Self_Id : constant Task_Id := Self;
285
286 begin
287 -- Update the protected object's owner
288
289 Object.Owner := Self_Id;
290
291 -- Increase protected object nesting level
292
293 Self_Id.Common.Protected_Action_Nesting :=
294 Self_Id.Common.Protected_Action_Nesting + 1;
295 end;
296 end if;
297 end Lock_Entries_With_Status;
298
299 ----------------------------
300 -- Lock_Read_Only_Entries --
301 ----------------------------
302
303 procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
304 Ceiling_Violation : Boolean;
305
306 begin
307 if Object.Finalized then
308 raise Program_Error with "protected object is finalized";
309 end if;
310
311 -- If pragma Detect_Blocking is active then, as described in the ARM
312 -- 9.5.1, par. 15, we must check whether this is an external call on a
313 -- protected subprogram with the same target object as that of the
314 -- protected action that is currently in progress (i.e., if the caller
315 -- is already the protected object's owner). If this is the case hence
316 -- Program_Error must be raised.
317
318 -- Note that in this case (getting read access), several tasks may
319 -- have read ownership of the protected object, so that this method of
320 -- storing the (single) protected object's owner does not work
321 -- reliably for read locks. However, this is the approach taken for two
322 -- major reasons: first, this function is not currently being used (it
323 -- is provided for possible future use), and second, it largely
324 -- simplifies the implementation.
325
326 if Detect_Blocking and then Object.Owner = Self then
327 raise Program_Error;
328 end if;
329
330 Read_Lock (Object.L'Access, Ceiling_Violation);
331
332 if Ceiling_Violation then
333 raise Program_Error with "ceiling violation";
334 end if;
335
336 -- We are entering in a protected action, so that we increase the
337 -- protected object nesting level (if pragma Detect_Blocking is
338 -- active), and update the protected object's owner.
339
340 if Detect_Blocking then
341 declare
342 Self_Id : constant Task_Id := Self;
343
344 begin
345 -- Update the protected object's owner
346
347 Object.Owner := Self_Id;
348
349 -- Increase protected object nesting level
350
351 Self_Id.Common.Protected_Action_Nesting :=
352 Self_Id.Common.Protected_Action_Nesting + 1;
353 end;
354 end if;
355 end Lock_Read_Only_Entries;
356
357 -----------------------
358 -- Number_Of_Entries --
359 -----------------------
360
361 function Number_Of_Entries
362 (Object : Protection_Entries_Access) return Entry_Index
363 is
364 begin
365 return Entry_Index (Object.Num_Entries);
366 end Number_Of_Entries;
367
368 -----------------
369 -- Set_Ceiling --
370 -----------------
371
372 procedure Set_Ceiling
373 (Object : Protection_Entries_Access;
374 Prio : System.Any_Priority) is
375 begin
376 Object.New_Ceiling := Prio;
377 end Set_Ceiling;
378
379 ---------------------
380 -- Set_Entry_Names --
381 ---------------------
382
383 procedure Set_Entry_Names
384 (Object : Protection_Entries_Access;
385 Names : Protected_Entry_Names_Access)
386 is
387 begin
388 Object.Entry_Names := Names;
389 end Set_Entry_Names;
390
391 --------------------
392 -- Unlock_Entries --
393 --------------------
394
395 procedure Unlock_Entries (Object : Protection_Entries_Access) is
396 begin
397 -- We are exiting from a protected action, so that we decrease the
398 -- protected object nesting level (if pragma Detect_Blocking is
399 -- active), and remove ownership of the protected object.
400
401 if Detect_Blocking then
402 declare
403 Self_Id : constant Task_Id := Self;
404
405 begin
406 -- Calls to this procedure can only take place when being within
407 -- a protected action and when the caller is the protected
408 -- object's owner.
409
410 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
411 and then Object.Owner = Self_Id);
412
413 -- Remove ownership of the protected object
414
415 Object.Owner := Null_Task;
416
417 Self_Id.Common.Protected_Action_Nesting :=
418 Self_Id.Common.Protected_Action_Nesting - 1;
419 end;
420 end if;
421
422 -- Before releasing the mutex we must actually update its ceiling
423 -- priority if it has been changed.
424
425 if Object.New_Ceiling /= Object.Ceiling then
426 if Locking_Policy = 'C' then
427 System.Task_Primitives.Operations.Set_Ceiling
428 (Object.L'Access, Object.New_Ceiling);
429 end if;
430
431 Object.Ceiling := Object.New_Ceiling;
432 end if;
433
434 Unlock (Object.L'Access);
435 end Unlock_Entries;
436
437 end System.Tasking.Protected_Objects.Entries;