|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . T A S K I N G . R E N D E Z V O U S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
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 with System.Task_Primitives.Operations;
|
|
|
33 with System.Tasking.Entry_Calls;
|
|
|
34 with System.Tasking.Initialization;
|
|
|
35 with System.Tasking.Queuing;
|
|
|
36 with System.Tasking.Utilities;
|
|
|
37 with System.Tasking.Protected_Objects.Operations;
|
|
|
38 with System.Tasking.Debug;
|
|
|
39 with System.Restrictions;
|
|
|
40 with System.Parameters;
|
|
|
41
|
|
|
42 package body System.Tasking.Rendezvous is
|
|
|
43
|
|
|
44 package STPO renames System.Task_Primitives.Operations;
|
|
|
45 package POO renames Protected_Objects.Operations;
|
|
|
46 package POE renames Protected_Objects.Entries;
|
|
|
47
|
|
|
48 use Parameters;
|
|
|
49 use Task_Primitives.Operations;
|
|
|
50
|
|
|
51 type Select_Treatment is (
|
|
|
52 Accept_Alternative_Selected, -- alternative with non-null body
|
|
|
53 Accept_Alternative_Completed, -- alternative with null body
|
|
|
54 Else_Selected,
|
|
|
55 Terminate_Selected,
|
|
|
56 Accept_Alternative_Open,
|
|
|
57 No_Alternative_Open);
|
|
|
58
|
|
|
59 ----------------
|
|
|
60 -- Local Data --
|
|
|
61 ----------------
|
|
|
62
|
|
|
63 Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
|
|
|
64 (Simple_Mode => No_Alternative_Open,
|
|
|
65 Else_Mode => Else_Selected,
|
|
|
66 Terminate_Mode => Terminate_Selected,
|
|
|
67 Delay_Mode => No_Alternative_Open);
|
|
|
68
|
|
|
69 New_State : constant array (Boolean, Entry_Call_State)
|
|
|
70 of Entry_Call_State :=
|
|
|
71 (True =>
|
|
|
72 (Never_Abortable => Never_Abortable,
|
|
|
73 Not_Yet_Abortable => Now_Abortable,
|
|
|
74 Was_Abortable => Now_Abortable,
|
|
|
75 Now_Abortable => Now_Abortable,
|
|
|
76 Done => Done,
|
|
|
77 Cancelled => Cancelled),
|
|
|
78 False =>
|
|
|
79 (Never_Abortable => Never_Abortable,
|
|
|
80 Not_Yet_Abortable => Not_Yet_Abortable,
|
|
|
81 Was_Abortable => Was_Abortable,
|
|
|
82 Now_Abortable => Now_Abortable,
|
|
|
83 Done => Done,
|
|
|
84 Cancelled => Cancelled)
|
|
|
85 );
|
|
|
86
|
|
|
87 -----------------------
|
|
|
88 -- Local Subprograms --
|
|
|
89 -----------------------
|
|
|
90
|
|
|
91 procedure Local_Defer_Abort (Self_Id : Task_Id) renames
|
|
|
92 System.Tasking.Initialization.Defer_Abort_Nestable;
|
|
|
93
|
|
|
94 procedure Local_Undefer_Abort (Self_Id : Task_Id) renames
|
|
|
95 System.Tasking.Initialization.Undefer_Abort_Nestable;
|
|
|
96
|
|
|
97 -- Florist defers abort around critical sections that make entry calls
|
|
|
98 -- to the Interrupt_Manager task, which violates the general rule about
|
|
|
99 -- top-level runtime system calls from abort-deferred regions. It is not
|
|
|
100 -- that this is unsafe, but when it occurs in "normal" programs it usually
|
|
|
101 -- means either the user is trying to do a potentially blocking operation
|
|
|
102 -- from within a protected object, or there is a runtime system/compiler
|
|
|
103 -- error that has failed to undefer an earlier abort deferral. Thus, for
|
|
|
104 -- debugging it may be wise to modify the above renamings to the
|
|
|
105 -- non-nestable forms.
|
|
|
106
|
|
|
107 procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id);
|
|
|
108 -- Internal version of Complete_Rendezvous, used to implement
|
|
|
109 -- Complete_Rendezvous and Exceptional_Complete_Rendezvous.
|
|
|
110 -- Should be called holding no locks, generally with abort
|
|
|
111 -- not yet deferred.
|
|
|
112
|
|
|
113 procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
|
|
|
114 pragma Inline (Boost_Priority);
|
|
|
115 -- Call this only with abort deferred and holding lock of Acceptor
|
|
|
116
|
|
|
117 procedure Call_Synchronous
|
|
|
118 (Acceptor : Task_Id;
|
|
|
119 E : Task_Entry_Index;
|
|
|
120 Uninterpreted_Data : System.Address;
|
|
|
121 Mode : Call_Modes;
|
|
|
122 Rendezvous_Successful : out Boolean);
|
|
|
123 pragma Inline (Call_Synchronous);
|
|
|
124 -- This call is used to make a simple or conditional entry call.
|
|
|
125 -- Called from Call_Simple and Task_Entry_Call.
|
|
|
126
|
|
|
127 procedure Setup_For_Rendezvous_With_Body
|
|
|
128 (Entry_Call : Entry_Call_Link;
|
|
|
129 Acceptor : Task_Id);
|
|
|
130 pragma Inline (Setup_For_Rendezvous_With_Body);
|
|
|
131 -- Call this only with abort deferred and holding lock of Acceptor. When
|
|
|
132 -- a rendezvous selected (ready for rendezvous) we need to save previous
|
|
|
133 -- caller and adjust the priority. Also we need to make this call not
|
|
|
134 -- Abortable (Cancellable) since the rendezvous has already been started.
|
|
|
135
|
|
|
136 procedure Wait_For_Call (Self_Id : Task_Id);
|
|
|
137 pragma Inline (Wait_For_Call);
|
|
|
138 -- Call this only with abort deferred and holding lock of Self_Id. An
|
|
|
139 -- accepting task goes into Sleep by calling this routine waiting for a
|
|
|
140 -- call from the caller or waiting for an abort. Make sure Self_Id is
|
|
|
141 -- locked before calling this routine.
|
|
|
142
|
|
|
143 -----------------
|
|
|
144 -- Accept_Call --
|
|
|
145 -----------------
|
|
|
146
|
|
|
147 procedure Accept_Call
|
|
|
148 (E : Task_Entry_Index;
|
|
|
149 Uninterpreted_Data : out System.Address)
|
|
|
150 is
|
|
|
151 Self_Id : constant Task_Id := STPO.Self;
|
|
|
152 Caller : Task_Id := null;
|
|
|
153 Open_Accepts : aliased Accept_List (1 .. 1);
|
|
|
154 Entry_Call : Entry_Call_Link;
|
|
|
155
|
|
|
156 begin
|
|
|
157 Initialization.Defer_Abort (Self_Id);
|
|
|
158
|
|
|
159 if Single_Lock then
|
|
|
160 Lock_RTS;
|
|
|
161 end if;
|
|
|
162
|
|
|
163 STPO.Write_Lock (Self_Id);
|
|
|
164
|
|
|
165 if not Self_Id.Callable then
|
|
|
166 pragma Assert (Self_Id.Pending_ATC_Level = 0);
|
|
|
167
|
|
|
168 pragma Assert (Self_Id.Pending_Action);
|
|
|
169
|
|
|
170 STPO.Unlock (Self_Id);
|
|
|
171
|
|
|
172 if Single_Lock then
|
|
|
173 Unlock_RTS;
|
|
|
174 end if;
|
|
|
175
|
|
|
176 Initialization.Undefer_Abort (Self_Id);
|
|
|
177
|
|
|
178 -- Should never get here ???
|
|
|
179
|
|
|
180 pragma Assert (False);
|
|
|
181 raise Standard'Abort_Signal;
|
|
|
182 end if;
|
|
|
183
|
|
|
184 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
|
|
|
185
|
|
|
186 if Entry_Call /= null then
|
|
|
187 Caller := Entry_Call.Self;
|
|
|
188 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
|
|
|
189 Uninterpreted_Data := Entry_Call.Uninterpreted_Data;
|
|
|
190
|
|
|
191 else
|
|
|
192 -- Wait for a caller
|
|
|
193
|
|
|
194 Open_Accepts (1).Null_Body := False;
|
|
|
195 Open_Accepts (1).S := E;
|
|
|
196 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
|
|
|
197
|
|
|
198 -- Wait for normal call
|
|
|
199
|
|
|
200 pragma Debug
|
|
|
201 (Debug.Trace (Self_Id, "Accept_Call: wait", 'R'));
|
|
|
202 Wait_For_Call (Self_Id);
|
|
|
203
|
|
|
204 pragma Assert (Self_Id.Open_Accepts = null);
|
|
|
205
|
|
|
206 if Self_Id.Common.Call /= null then
|
|
|
207 Caller := Self_Id.Common.Call.Self;
|
|
|
208 Uninterpreted_Data :=
|
|
|
209 Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
|
|
|
210 else
|
|
|
211 -- Case of an aborted task
|
|
|
212
|
|
|
213 Uninterpreted_Data := System.Null_Address;
|
|
|
214 end if;
|
|
|
215 end if;
|
|
|
216
|
|
|
217 -- Self_Id.Common.Call should already be updated by the Caller. On
|
|
|
218 -- return, we will start the rendezvous.
|
|
|
219
|
|
|
220 STPO.Unlock (Self_Id);
|
|
|
221
|
|
|
222 if Single_Lock then
|
|
|
223 Unlock_RTS;
|
|
|
224 end if;
|
|
|
225
|
|
|
226 Initialization.Undefer_Abort (Self_Id);
|
|
|
227
|
|
|
228 end Accept_Call;
|
|
|
229
|
|
|
230 --------------------
|
|
|
231 -- Accept_Trivial --
|
|
|
232 --------------------
|
|
|
233
|
|
|
234 procedure Accept_Trivial (E : Task_Entry_Index) is
|
|
|
235 Self_Id : constant Task_Id := STPO.Self;
|
|
|
236 Caller : Task_Id := null;
|
|
|
237 Open_Accepts : aliased Accept_List (1 .. 1);
|
|
|
238 Entry_Call : Entry_Call_Link;
|
|
|
239
|
|
|
240 begin
|
|
|
241 Initialization.Defer_Abort_Nestable (Self_Id);
|
|
|
242
|
|
|
243 if Single_Lock then
|
|
|
244 Lock_RTS;
|
|
|
245 end if;
|
|
|
246
|
|
|
247 STPO.Write_Lock (Self_Id);
|
|
|
248
|
|
|
249 if not Self_Id.Callable then
|
|
|
250 pragma Assert (Self_Id.Pending_ATC_Level = 0);
|
|
|
251
|
|
|
252 pragma Assert (Self_Id.Pending_Action);
|
|
|
253
|
|
|
254 STPO.Unlock (Self_Id);
|
|
|
255
|
|
|
256 if Single_Lock then
|
|
|
257 Unlock_RTS;
|
|
|
258 end if;
|
|
|
259
|
|
|
260 Initialization.Undefer_Abort_Nestable (Self_Id);
|
|
|
261
|
|
|
262 -- Should never get here ???
|
|
|
263
|
|
|
264 pragma Assert (False);
|
|
|
265 raise Standard'Abort_Signal;
|
|
|
266 end if;
|
|
|
267
|
|
|
268 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
|
|
|
269
|
|
|
270 if Entry_Call = null then
|
|
|
271
|
|
|
272 -- Need to wait for entry call
|
|
|
273
|
|
|
274 Open_Accepts (1).Null_Body := True;
|
|
|
275 Open_Accepts (1).S := E;
|
|
|
276 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
|
|
|
277
|
|
|
278 pragma Debug
|
|
|
279 (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R'));
|
|
|
280
|
|
|
281 Wait_For_Call (Self_Id);
|
|
|
282
|
|
|
283 pragma Assert (Self_Id.Open_Accepts = null);
|
|
|
284
|
|
|
285 -- No need to do anything special here for pending abort.
|
|
|
286 -- Abort_Signal will be raised by Undefer on exit.
|
|
|
287
|
|
|
288 STPO.Unlock (Self_Id);
|
|
|
289
|
|
|
290 -- Found caller already waiting
|
|
|
291
|
|
|
292 else
|
|
|
293 pragma Assert (Entry_Call.State < Done);
|
|
|
294
|
|
|
295 STPO.Unlock (Self_Id);
|
|
|
296 Caller := Entry_Call.Self;
|
|
|
297
|
|
|
298 STPO.Write_Lock (Caller);
|
|
|
299 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
|
|
|
300 STPO.Unlock (Caller);
|
|
|
301 end if;
|
|
|
302
|
|
|
303 if Single_Lock then
|
|
|
304 Unlock_RTS;
|
|
|
305 end if;
|
|
|
306
|
|
|
307 Initialization.Undefer_Abort_Nestable (Self_Id);
|
|
|
308 end Accept_Trivial;
|
|
|
309
|
|
|
310 --------------------
|
|
|
311 -- Boost_Priority --
|
|
|
312 --------------------
|
|
|
313
|
|
|
314 procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is
|
|
|
315 Caller : constant Task_Id := Call.Self;
|
|
|
316 Caller_Prio : constant System.Any_Priority := Get_Priority (Caller);
|
|
|
317 Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor);
|
|
|
318 begin
|
|
|
319 if Caller_Prio > Acceptor_Prio then
|
|
|
320 Call.Acceptor_Prev_Priority := Acceptor_Prio;
|
|
|
321 Set_Priority (Acceptor, Caller_Prio);
|
|
|
322 else
|
|
|
323 Call.Acceptor_Prev_Priority := Priority_Not_Boosted;
|
|
|
324 end if;
|
|
|
325 end Boost_Priority;
|
|
|
326
|
|
|
327 -----------------
|
|
|
328 -- Call_Simple --
|
|
|
329 -----------------
|
|
|
330
|
|
|
331 procedure Call_Simple
|
|
|
332 (Acceptor : Task_Id;
|
|
|
333 E : Task_Entry_Index;
|
|
|
334 Uninterpreted_Data : System.Address)
|
|
|
335 is
|
|
|
336 Rendezvous_Successful : Boolean;
|
|
|
337 pragma Unreferenced (Rendezvous_Successful);
|
|
|
338
|
|
|
339 begin
|
|
|
340 -- If pragma Detect_Blocking is active then Program_Error must be
|
|
|
341 -- raised if this potentially blocking operation is called from a
|
|
|
342 -- protected action.
|
|
|
343
|
|
|
344 if System.Tasking.Detect_Blocking
|
|
|
345 and then STPO.Self.Common.Protected_Action_Nesting > 0
|
|
|
346 then
|
|
|
347 raise Program_Error with
|
|
|
348 "potentially blocking operation";
|
|
|
349 end if;
|
|
|
350
|
|
|
351 Call_Synchronous
|
|
|
352 (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
|
|
|
353 end Call_Simple;
|
|
|
354
|
|
|
355 ----------------------
|
|
|
356 -- Call_Synchronous --
|
|
|
357 ----------------------
|
|
|
358
|
|
|
359 procedure Call_Synchronous
|
|
|
360 (Acceptor : Task_Id;
|
|
|
361 E : Task_Entry_Index;
|
|
|
362 Uninterpreted_Data : System.Address;
|
|
|
363 Mode : Call_Modes;
|
|
|
364 Rendezvous_Successful : out Boolean)
|
|
|
365 is
|
|
|
366 Self_Id : constant Task_Id := STPO.Self;
|
|
|
367 Level : ATC_Level;
|
|
|
368 Entry_Call : Entry_Call_Link;
|
|
|
369
|
|
|
370 begin
|
|
|
371 pragma Assert (Mode /= Asynchronous_Call);
|
|
|
372
|
|
|
373 Local_Defer_Abort (Self_Id);
|
|
|
374 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
|
|
|
375 pragma Debug
|
|
|
376 (Debug.Trace (Self_Id, "CS: entered ATC level: " &
|
|
|
377 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
|
|
|
378 Level := Self_Id.ATC_Nesting_Level;
|
|
|
379 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
|
|
|
380 Entry_Call.Next := null;
|
|
|
381 Entry_Call.Mode := Mode;
|
|
|
382 Entry_Call.Cancellation_Attempted := False;
|
|
|
383
|
|
|
384 -- If this is a call made inside of an abort deferred region,
|
|
|
385 -- the call should be never abortable.
|
|
|
386
|
|
|
387 Entry_Call.State :=
|
|
|
388 (if Self_Id.Deferral_Level > 1
|
|
|
389 then Never_Abortable
|
|
|
390 else Now_Abortable);
|
|
|
391
|
|
|
392 Entry_Call.E := Entry_Index (E);
|
|
|
393 Entry_Call.Prio := Get_Priority (Self_Id);
|
|
|
394 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
|
|
|
395 Entry_Call.Called_Task := Acceptor;
|
|
|
396 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
|
|
|
397 Entry_Call.With_Abort := True;
|
|
|
398
|
|
|
399 -- Note: the caller will undefer abort on return (see WARNING above)
|
|
|
400
|
|
|
401 if Single_Lock then
|
|
|
402 Lock_RTS;
|
|
|
403 end if;
|
|
|
404
|
|
|
405 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
|
|
|
406 STPO.Write_Lock (Self_Id);
|
|
|
407 Utilities.Exit_One_ATC_Level (Self_Id);
|
|
|
408 STPO.Unlock (Self_Id);
|
|
|
409
|
|
|
410 if Single_Lock then
|
|
|
411 Unlock_RTS;
|
|
|
412 end if;
|
|
|
413
|
|
|
414 Local_Undefer_Abort (Self_Id);
|
|
|
415 raise Tasking_Error;
|
|
|
416 end if;
|
|
|
417
|
|
|
418 STPO.Write_Lock (Self_Id);
|
|
|
419 pragma Debug
|
|
|
420 (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R'));
|
|
|
421 Entry_Calls.Wait_For_Completion (Entry_Call);
|
|
|
422 pragma Debug
|
|
|
423 (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
|
|
|
424 Rendezvous_Successful := Entry_Call.State = Done;
|
|
|
425 STPO.Unlock (Self_Id);
|
|
|
426
|
|
|
427 if Single_Lock then
|
|
|
428 Unlock_RTS;
|
|
|
429 end if;
|
|
|
430
|
|
|
431 Local_Undefer_Abort (Self_Id);
|
|
|
432 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
|
|
|
433 end Call_Synchronous;
|
|
|
434
|
|
|
435 --------------
|
|
|
436 -- Callable --
|
|
|
437 --------------
|
|
|
438
|
|
|
439 function Callable (T : Task_Id) return Boolean is
|
|
|
440 Result : Boolean;
|
|
|
441 Self_Id : constant Task_Id := STPO.Self;
|
|
|
442
|
|
|
443 begin
|
|
|
444 Initialization.Defer_Abort_Nestable (Self_Id);
|
|
|
445
|
|
|
446 if Single_Lock then
|
|
|
447 Lock_RTS;
|
|
|
448 end if;
|
|
|
449
|
|
|
450 STPO.Write_Lock (T);
|
|
|
451 Result := T.Callable;
|
|
|
452 STPO.Unlock (T);
|
|
|
453
|
|
|
454 if Single_Lock then
|
|
|
455 Unlock_RTS;
|
|
|
456 end if;
|
|
|
457
|
|
|
458 Initialization.Undefer_Abort_Nestable (Self_Id);
|
|
|
459 return Result;
|
|
|
460 end Callable;
|
|
|
461
|
|
|
462 ----------------------------
|
|
|
463 -- Cancel_Task_Entry_Call --
|
|
|
464 ----------------------------
|
|
|
465
|
|
|
466 procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
|
|
|
467 begin
|
|
|
468 Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled);
|
|
|
469 end Cancel_Task_Entry_Call;
|
|
|
470
|
|
|
471 -------------------------
|
|
|
472 -- Complete_Rendezvous --
|
|
|
473 -------------------------
|
|
|
474
|
|
|
475 procedure Complete_Rendezvous is
|
|
|
476 begin
|
|
|
477 Local_Complete_Rendezvous (Ada.Exceptions.Null_Id);
|
|
|
478 end Complete_Rendezvous;
|
|
|
479
|
|
|
480 -------------------------------------
|
|
|
481 -- Exceptional_Complete_Rendezvous --
|
|
|
482 -------------------------------------
|
|
|
483
|
|
|
484 procedure Exceptional_Complete_Rendezvous
|
|
|
485 (Ex : Ada.Exceptions.Exception_Id)
|
|
|
486 is
|
|
|
487 procedure Internal_Reraise;
|
|
|
488 pragma No_Return (Internal_Reraise);
|
|
|
489 pragma Import (C, Internal_Reraise, "__gnat_reraise");
|
|
|
490
|
|
|
491 begin
|
|
|
492 Local_Complete_Rendezvous (Ex);
|
|
|
493 Internal_Reraise;
|
|
|
494
|
|
|
495 -- ??? Do we need to give precedence to Program_Error that might be
|
|
|
496 -- raised due to failure of finalization, over Tasking_Error from
|
|
|
497 -- failure of requeue?
|
|
|
498 end Exceptional_Complete_Rendezvous;
|
|
|
499
|
|
|
500 -------------------------------
|
|
|
501 -- Local_Complete_Rendezvous --
|
|
|
502 -------------------------------
|
|
|
503
|
|
|
504 procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is
|
|
|
505 Self_Id : constant Task_Id := STPO.Self;
|
|
|
506 Entry_Call : Entry_Call_Link := Self_Id.Common.Call;
|
|
|
507 Caller : Task_Id;
|
|
|
508 Called_PO : STPE.Protection_Entries_Access;
|
|
|
509 Acceptor_Prev_Priority : Integer;
|
|
|
510
|
|
|
511 Ceiling_Violation : Boolean;
|
|
|
512
|
|
|
513 use type Ada.Exceptions.Exception_Id;
|
|
|
514 procedure Transfer_Occurrence
|
|
|
515 (Target : Ada.Exceptions.Exception_Occurrence_Access;
|
|
|
516 Source : Ada.Exceptions.Exception_Occurrence);
|
|
|
517 pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
|
|
|
518
|
|
|
519 begin
|
|
|
520 -- The deferral level is critical here, since we want to raise an
|
|
|
521 -- exception or allow abort to take place, if there is an exception or
|
|
|
522 -- abort pending.
|
|
|
523
|
|
|
524 pragma Debug
|
|
|
525 (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R'));
|
|
|
526
|
|
|
527 if Ex = Ada.Exceptions.Null_Id then
|
|
|
528
|
|
|
529 -- The call came from normal end-of-rendezvous, so abort is not yet
|
|
|
530 -- deferred.
|
|
|
531
|
|
|
532 Initialization.Defer_Abort (Self_Id);
|
|
|
533
|
|
|
534 elsif ZCX_By_Default then
|
|
|
535
|
|
|
536 -- With ZCX, aborts are not automatically deferred in handlers
|
|
|
537
|
|
|
538 Initialization.Defer_Abort (Self_Id);
|
|
|
539 end if;
|
|
|
540
|
|
|
541 -- We need to clean up any accepts which Self may have been serving when
|
|
|
542 -- it was aborted.
|
|
|
543
|
|
|
544 if Ex = Standard'Abort_Signal'Identity then
|
|
|
545 if Single_Lock then
|
|
|
546 Lock_RTS;
|
|
|
547 end if;
|
|
|
548
|
|
|
549 while Entry_Call /= null loop
|
|
|
550 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
|
|
|
551
|
|
|
552 -- All forms of accept make sure that the acceptor is not
|
|
|
553 -- completed, before accepting further calls, so that we
|
|
|
554 -- can be sure that no further calls are made after the
|
|
|
555 -- current calls are purged.
|
|
|
556
|
|
|
557 Caller := Entry_Call.Self;
|
|
|
558
|
|
|
559 -- Take write lock. This follows the lock precedence rule that
|
|
|
560 -- Caller may be locked while holding lock of Acceptor. Complete
|
|
|
561 -- the call abnormally, with exception.
|
|
|
562
|
|
|
563 STPO.Write_Lock (Caller);
|
|
|
564 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
|
|
|
565 STPO.Unlock (Caller);
|
|
|
566 Entry_Call := Entry_Call.Acceptor_Prev_Call;
|
|
|
567 end loop;
|
|
|
568
|
|
|
569 if Single_Lock then
|
|
|
570 Unlock_RTS;
|
|
|
571 end if;
|
|
|
572
|
|
|
573 else
|
|
|
574 Caller := Entry_Call.Self;
|
|
|
575
|
|
|
576 if Entry_Call.Needs_Requeue then
|
|
|
577
|
|
|
578 -- We dare not lock Self_Id at the same time as Caller, for fear
|
|
|
579 -- of deadlock.
|
|
|
580
|
|
|
581 Entry_Call.Needs_Requeue := False;
|
|
|
582 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
|
|
|
583
|
|
|
584 if Entry_Call.Called_Task /= null then
|
|
|
585
|
|
|
586 -- Requeue to another task entry
|
|
|
587
|
|
|
588 if Single_Lock then
|
|
|
589 Lock_RTS;
|
|
|
590 end if;
|
|
|
591
|
|
|
592 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
|
|
|
593 if Single_Lock then
|
|
|
594 Unlock_RTS;
|
|
|
595 end if;
|
|
|
596
|
|
|
597 Initialization.Undefer_Abort (Self_Id);
|
|
|
598 raise Tasking_Error;
|
|
|
599 end if;
|
|
|
600
|
|
|
601 if Single_Lock then
|
|
|
602 Unlock_RTS;
|
|
|
603 end if;
|
|
|
604
|
|
|
605 else
|
|
|
606 -- Requeue to a protected entry
|
|
|
607
|
|
|
608 Called_PO := POE.To_Protection (Entry_Call.Called_PO);
|
|
|
609 STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation);
|
|
|
610
|
|
|
611 if Ceiling_Violation then
|
|
|
612 pragma Assert (Ex = Ada.Exceptions.Null_Id);
|
|
|
613 Entry_Call.Exception_To_Raise := Program_Error'Identity;
|
|
|
614
|
|
|
615 if Single_Lock then
|
|
|
616 Lock_RTS;
|
|
|
617 end if;
|
|
|
618
|
|
|
619 STPO.Write_Lock (Caller);
|
|
|
620 Initialization.Wakeup_Entry_Caller
|
|
|
621 (Self_Id, Entry_Call, Done);
|
|
|
622 STPO.Unlock (Caller);
|
|
|
623
|
|
|
624 if Single_Lock then
|
|
|
625 Unlock_RTS;
|
|
|
626 end if;
|
|
|
627
|
|
|
628 else
|
|
|
629 POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call);
|
|
|
630 POO.PO_Service_Entries (Self_Id, Called_PO);
|
|
|
631 end if;
|
|
|
632 end if;
|
|
|
633
|
|
|
634 Entry_Calls.Reset_Priority
|
|
|
635 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
|
|
|
636
|
|
|
637 else
|
|
|
638 -- The call does not need to be requeued
|
|
|
639
|
|
|
640 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
|
|
|
641 Entry_Call.Exception_To_Raise := Ex;
|
|
|
642
|
|
|
643 if Single_Lock then
|
|
|
644 Lock_RTS;
|
|
|
645 end if;
|
|
|
646
|
|
|
647 STPO.Write_Lock (Caller);
|
|
|
648
|
|
|
649 -- Done with Caller locked to make sure that Wakeup is not lost
|
|
|
650
|
|
|
651 if Ex /= Ada.Exceptions.Null_Id then
|
|
|
652 Transfer_Occurrence
|
|
|
653 (Caller.Common.Compiler_Data.Current_Excep'Access,
|
|
|
654 Self_Id.Common.Compiler_Data.Current_Excep);
|
|
|
655 end if;
|
|
|
656
|
|
|
657 Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority;
|
|
|
658 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
|
|
|
659
|
|
|
660 STPO.Unlock (Caller);
|
|
|
661
|
|
|
662 if Single_Lock then
|
|
|
663 Unlock_RTS;
|
|
|
664 end if;
|
|
|
665
|
|
|
666 Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
|
|
|
667 end if;
|
|
|
668 end if;
|
|
|
669
|
|
|
670 Initialization.Undefer_Abort (Self_Id);
|
|
|
671 end Local_Complete_Rendezvous;
|
|
|
672
|
|
|
673 -------------------------------------
|
|
|
674 -- Requeue_Protected_To_Task_Entry --
|
|
|
675 -------------------------------------
|
|
|
676
|
|
|
677 procedure Requeue_Protected_To_Task_Entry
|
|
|
678 (Object : STPE.Protection_Entries_Access;
|
|
|
679 Acceptor : Task_Id;
|
|
|
680 E : Task_Entry_Index;
|
|
|
681 With_Abort : Boolean)
|
|
|
682 is
|
|
|
683 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
|
|
|
684 begin
|
|
|
685 pragma Assert (STPO.Self.Deferral_Level > 0);
|
|
|
686
|
|
|
687 Entry_Call.E := Entry_Index (E);
|
|
|
688 Entry_Call.Called_Task := Acceptor;
|
|
|
689 Entry_Call.Called_PO := Null_Address;
|
|
|
690 Entry_Call.With_Abort := With_Abort;
|
|
|
691 Object.Call_In_Progress := null;
|
|
|
692 end Requeue_Protected_To_Task_Entry;
|
|
|
693
|
|
|
694 ------------------------
|
|
|
695 -- Requeue_Task_Entry --
|
|
|
696 ------------------------
|
|
|
697
|
|
|
698 procedure Requeue_Task_Entry
|
|
|
699 (Acceptor : Task_Id;
|
|
|
700 E : Task_Entry_Index;
|
|
|
701 With_Abort : Boolean)
|
|
|
702 is
|
|
|
703 Self_Id : constant Task_Id := STPO.Self;
|
|
|
704 Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
|
|
|
705 begin
|
|
|
706 Initialization.Defer_Abort (Self_Id);
|
|
|
707 Entry_Call.Needs_Requeue := True;
|
|
|
708 Entry_Call.With_Abort := With_Abort;
|
|
|
709 Entry_Call.E := Entry_Index (E);
|
|
|
710 Entry_Call.Called_Task := Acceptor;
|
|
|
711 Initialization.Undefer_Abort (Self_Id);
|
|
|
712 end Requeue_Task_Entry;
|
|
|
713
|
|
|
714 --------------------
|
|
|
715 -- Selective_Wait --
|
|
|
716 --------------------
|
|
|
717
|
|
|
718 procedure Selective_Wait
|
|
|
719 (Open_Accepts : Accept_List_Access;
|
|
|
720 Select_Mode : Select_Modes;
|
|
|
721 Uninterpreted_Data : out System.Address;
|
|
|
722 Index : out Select_Index)
|
|
|
723 is
|
|
|
724 Self_Id : constant Task_Id := STPO.Self;
|
|
|
725 Entry_Call : Entry_Call_Link;
|
|
|
726 Treatment : Select_Treatment;
|
|
|
727 Caller : Task_Id;
|
|
|
728 Selection : Select_Index;
|
|
|
729 Open_Alternative : Boolean;
|
|
|
730
|
|
|
731 begin
|
|
|
732 Initialization.Defer_Abort (Self_Id);
|
|
|
733
|
|
|
734 if Single_Lock then
|
|
|
735 Lock_RTS;
|
|
|
736 end if;
|
|
|
737
|
|
|
738 STPO.Write_Lock (Self_Id);
|
|
|
739
|
|
|
740 if not Self_Id.Callable then
|
|
|
741 pragma Assert (Self_Id.Pending_ATC_Level = 0);
|
|
|
742
|
|
|
743 pragma Assert (Self_Id.Pending_Action);
|
|
|
744
|
|
|
745 STPO.Unlock (Self_Id);
|
|
|
746
|
|
|
747 if Single_Lock then
|
|
|
748 Unlock_RTS;
|
|
|
749 end if;
|
|
|
750
|
|
|
751 -- ??? In some cases abort is deferred more than once. Need to
|
|
|
752 -- figure out why this happens.
|
|
|
753
|
|
|
754 if Self_Id.Deferral_Level > 1 then
|
|
|
755 Self_Id.Deferral_Level := 1;
|
|
|
756 end if;
|
|
|
757
|
|
|
758 Initialization.Undefer_Abort (Self_Id);
|
|
|
759
|
|
|
760 -- Should never get here ???
|
|
|
761
|
|
|
762 pragma Assert (False);
|
|
|
763 raise Standard'Abort_Signal;
|
|
|
764 end if;
|
|
|
765
|
|
|
766 pragma Assert (Open_Accepts /= null);
|
|
|
767
|
|
|
768 Uninterpreted_Data := Null_Address;
|
|
|
769
|
|
|
770 Queuing.Select_Task_Entry_Call
|
|
|
771 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
|
|
|
772
|
|
|
773 -- Determine the kind and disposition of the select
|
|
|
774
|
|
|
775 Treatment := Default_Treatment (Select_Mode);
|
|
|
776 Self_Id.Chosen_Index := No_Rendezvous;
|
|
|
777
|
|
|
778 if Open_Alternative then
|
|
|
779 if Entry_Call /= null then
|
|
|
780 if Open_Accepts (Selection).Null_Body then
|
|
|
781 Treatment := Accept_Alternative_Completed;
|
|
|
782 else
|
|
|
783 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
|
|
|
784 Treatment := Accept_Alternative_Selected;
|
|
|
785 end if;
|
|
|
786
|
|
|
787 Self_Id.Chosen_Index := Selection;
|
|
|
788
|
|
|
789 elsif Treatment = No_Alternative_Open then
|
|
|
790 Treatment := Accept_Alternative_Open;
|
|
|
791 end if;
|
|
|
792 end if;
|
|
|
793
|
|
|
794 -- Handle the select according to the disposition selected above
|
|
|
795
|
|
|
796 case Treatment is
|
|
|
797 when Accept_Alternative_Selected =>
|
|
|
798
|
|
|
799 -- Ready to rendezvous
|
|
|
800
|
|
|
801 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
|
|
|
802
|
|
|
803 -- In this case the accept body is not Null_Body. Defer abort
|
|
|
804 -- until it gets into the accept body. The compiler has inserted
|
|
|
805 -- a call to Abort_Undefer as part of the entry expansion.
|
|
|
806
|
|
|
807 pragma Assert (Self_Id.Deferral_Level = 1);
|
|
|
808
|
|
|
809 Initialization.Defer_Abort_Nestable (Self_Id);
|
|
|
810 STPO.Unlock (Self_Id);
|
|
|
811
|
|
|
812 when Accept_Alternative_Completed =>
|
|
|
813
|
|
|
814 -- Accept body is null, so rendezvous is over immediately
|
|
|
815
|
|
|
816 STPO.Unlock (Self_Id);
|
|
|
817 Caller := Entry_Call.Self;
|
|
|
818
|
|
|
819 STPO.Write_Lock (Caller);
|
|
|
820 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
|
|
|
821 STPO.Unlock (Caller);
|
|
|
822
|
|
|
823 when Accept_Alternative_Open =>
|
|
|
824
|
|
|
825 -- Wait for caller
|
|
|
826
|
|
|
827 Self_Id.Open_Accepts := Open_Accepts;
|
|
|
828 pragma Debug
|
|
|
829 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
|
|
|
830
|
|
|
831 Wait_For_Call (Self_Id);
|
|
|
832
|
|
|
833 pragma Assert (Self_Id.Open_Accepts = null);
|
|
|
834
|
|
|
835 -- Self_Id.Common.Call should already be updated by the Caller if
|
|
|
836 -- not aborted. It might also be ready to do rendezvous even if
|
|
|
837 -- this wakes up due to an abort. Therefore, if the call is not
|
|
|
838 -- empty we need to do the rendezvous if the accept body is not
|
|
|
839 -- Null_Body.
|
|
|
840
|
|
|
841 -- Aren't the first two conditions below redundant???
|
|
|
842
|
|
|
843 if Self_Id.Chosen_Index /= No_Rendezvous
|
|
|
844 and then Self_Id.Common.Call /= null
|
|
|
845 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
|
|
|
846 then
|
|
|
847 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
|
|
|
848
|
|
|
849 pragma Assert
|
|
|
850 (Self_Id.Deferral_Level = 1
|
|
|
851 or else
|
|
|
852 (Self_Id.Deferral_Level = 0
|
|
|
853 and then not Restrictions.Abort_Allowed));
|
|
|
854
|
|
|
855 Initialization.Defer_Abort_Nestable (Self_Id);
|
|
|
856
|
|
|
857 -- Leave abort deferred until the accept body
|
|
|
858 -- The compiler has inserted a call to Abort_Undefer as part of
|
|
|
859 -- the entry expansion.
|
|
|
860 end if;
|
|
|
861
|
|
|
862 STPO.Unlock (Self_Id);
|
|
|
863
|
|
|
864 when Else_Selected =>
|
|
|
865 pragma Assert (Self_Id.Open_Accepts = null);
|
|
|
866
|
|
|
867 STPO.Unlock (Self_Id);
|
|
|
868
|
|
|
869 when Terminate_Selected =>
|
|
|
870
|
|
|
871 -- Terminate alternative is open
|
|
|
872
|
|
|
873 Self_Id.Open_Accepts := Open_Accepts;
|
|
|
874 Self_Id.Common.State := Acceptor_Sleep;
|
|
|
875
|
|
|
876 -- Notify ancestors that this task is on a terminate alternative
|
|
|
877
|
|
|
878 STPO.Unlock (Self_Id);
|
|
|
879 Utilities.Make_Passive (Self_Id, Task_Completed => False);
|
|
|
880 STPO.Write_Lock (Self_Id);
|
|
|
881
|
|
|
882 -- Wait for normal entry call or termination
|
|
|
883
|
|
|
884 Wait_For_Call (Self_Id);
|
|
|
885
|
|
|
886 pragma Assert (Self_Id.Open_Accepts = null);
|
|
|
887
|
|
|
888 if Self_Id.Terminate_Alternative then
|
|
|
889
|
|
|
890 -- An entry call should have reset this to False, so we must be
|
|
|
891 -- aborted. We cannot be in an async. select, since that is not
|
|
|
892 -- legal, so the abort must be of the entire task. Therefore,
|
|
|
893 -- we do not need to cancel the terminate alternative. The
|
|
|
894 -- cleanup will be done in Complete_Master.
|
|
|
895
|
|
|
896 pragma Assert (Self_Id.Pending_ATC_Level = 0);
|
|
|
897 pragma Assert (Self_Id.Awake_Count = 0);
|
|
|
898
|
|
|
899 STPO.Unlock (Self_Id);
|
|
|
900
|
|
|
901 if Single_Lock then
|
|
|
902 Unlock_RTS;
|
|
|
903 end if;
|
|
|
904
|
|
|
905 Index := Self_Id.Chosen_Index;
|
|
|
906 Initialization.Undefer_Abort_Nestable (Self_Id);
|
|
|
907
|
|
|
908 if Self_Id.Pending_Action then
|
|
|
909 Initialization.Do_Pending_Action (Self_Id);
|
|
|
910 end if;
|
|
|
911
|
|
|
912 return;
|
|
|
913
|
|
|
914 else
|
|
|
915 -- Self_Id.Common.Call and Self_Id.Chosen_Index
|
|
|
916 -- should already be updated by the Caller.
|
|
|
917
|
|
|
918 if Self_Id.Chosen_Index /= No_Rendezvous
|
|
|
919 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
|
|
|
920 then
|
|
|
921 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
|
|
|
922
|
|
|
923 pragma Assert (Self_Id.Deferral_Level = 1);
|
|
|
924
|
|
|
925 -- We need an extra defer here, to keep abort
|
|
|
926 -- deferred until we get into the accept body
|
|
|
927 -- The compiler has inserted a call to Abort_Undefer as part
|
|
|
928 -- of the entry expansion.
|
|
|
929
|
|
|
930 Initialization.Defer_Abort_Nestable (Self_Id);
|
|
|
931 end if;
|
|
|
932 end if;
|
|
|
933
|
|
|
934 STPO.Unlock (Self_Id);
|
|
|
935
|
|
|
936 when No_Alternative_Open =>
|
|
|
937
|
|
|
938 -- In this case, Index will be No_Rendezvous on return, which
|
|
|
939 -- should cause a Program_Error if it is not a Delay_Mode.
|
|
|
940
|
|
|
941 -- If delay alternative exists (Delay_Mode) we should suspend
|
|
|
942 -- until the delay expires.
|
|
|
943
|
|
|
944 Self_Id.Open_Accepts := null;
|
|
|
945
|
|
|
946 if Select_Mode = Delay_Mode then
|
|
|
947 Self_Id.Common.State := Delay_Sleep;
|
|
|
948
|
|
|
949 loop
|
|
|
950 exit when
|
|
|
951 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
|
|
|
952 Sleep (Self_Id, Delay_Sleep);
|
|
|
953 end loop;
|
|
|
954
|
|
|
955 Self_Id.Common.State := Runnable;
|
|
|
956 STPO.Unlock (Self_Id);
|
|
|
957
|
|
|
958 else
|
|
|
959 STPO.Unlock (Self_Id);
|
|
|
960
|
|
|
961 if Single_Lock then
|
|
|
962 Unlock_RTS;
|
|
|
963 end if;
|
|
|
964
|
|
|
965 Initialization.Undefer_Abort (Self_Id);
|
|
|
966 raise Program_Error with
|
|
|
967 "entry call not a delay mode";
|
|
|
968 end if;
|
|
|
969 end case;
|
|
|
970
|
|
|
971 if Single_Lock then
|
|
|
972 Unlock_RTS;
|
|
|
973 end if;
|
|
|
974
|
|
|
975 -- Caller has been chosen
|
|
|
976
|
|
|
977 -- Self_Id.Common.Call should already be updated by the Caller.
|
|
|
978
|
|
|
979 -- Self_Id.Chosen_Index should either be updated by the Caller
|
|
|
980 -- or by Test_Selective_Wait.
|
|
|
981
|
|
|
982 -- On return, we sill start rendezvous unless the accept body is
|
|
|
983 -- null. In the latter case, we will have already completed the RV.
|
|
|
984
|
|
|
985 Index := Self_Id.Chosen_Index;
|
|
|
986 Initialization.Undefer_Abort_Nestable (Self_Id);
|
|
|
987 end Selective_Wait;
|
|
|
988
|
|
|
989 ------------------------------------
|
|
|
990 -- Setup_For_Rendezvous_With_Body --
|
|
|
991 ------------------------------------
|
|
|
992
|
|
|
993 procedure Setup_For_Rendezvous_With_Body
|
|
|
994 (Entry_Call : Entry_Call_Link;
|
|
|
995 Acceptor : Task_Id) is
|
|
|
996 begin
|
|
|
997 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
|
|
|
998 Acceptor.Common.Call := Entry_Call;
|
|
|
999
|
|
|
1000 if Entry_Call.State = Now_Abortable then
|
|
|
1001 Entry_Call.State := Was_Abortable;
|
|
|
1002 end if;
|
|
|
1003
|
|
|
1004 Boost_Priority (Entry_Call, Acceptor);
|
|
|
1005 end Setup_For_Rendezvous_With_Body;
|
|
|
1006
|
|
|
1007 ----------------
|
|
|
1008 -- Task_Count --
|
|
|
1009 ----------------
|
|
|
1010
|
|
|
1011 function Task_Count (E : Task_Entry_Index) return Natural is
|
|
|
1012 Self_Id : constant Task_Id := STPO.Self;
|
|
|
1013 Return_Count : Natural;
|
|
|
1014
|
|
|
1015 begin
|
|
|
1016 Initialization.Defer_Abort (Self_Id);
|
|
|
1017
|
|
|
1018 if Single_Lock then
|
|
|
1019 Lock_RTS;
|
|
|
1020 end if;
|
|
|
1021
|
|
|
1022 STPO.Write_Lock (Self_Id);
|
|
|
1023 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
|
|
|
1024 STPO.Unlock (Self_Id);
|
|
|
1025
|
|
|
1026 if Single_Lock then
|
|
|
1027 Unlock_RTS;
|
|
|
1028 end if;
|
|
|
1029
|
|
|
1030 Initialization.Undefer_Abort (Self_Id);
|
|
|
1031
|
|
|
1032 return Return_Count;
|
|
|
1033 end Task_Count;
|
|
|
1034
|
|
|
1035 ----------------------
|
|
|
1036 -- Task_Do_Or_Queue --
|
|
|
1037 ----------------------
|
|
|
1038
|
|
|
1039 function Task_Do_Or_Queue
|
|
|
1040 (Self_ID : Task_Id;
|
|
|
1041 Entry_Call : Entry_Call_Link) return Boolean
|
|
|
1042 is
|
|
|
1043 E : constant Task_Entry_Index :=
|
|
|
1044 Task_Entry_Index (Entry_Call.E);
|
|
|
1045 Old_State : constant Entry_Call_State := Entry_Call.State;
|
|
|
1046 Acceptor : constant Task_Id := Entry_Call.Called_Task;
|
|
|
1047 Parent : constant Task_Id := Acceptor.Common.Parent;
|
|
|
1048 Null_Body : Boolean;
|
|
|
1049
|
|
|
1050 begin
|
|
|
1051 -- Find out whether Entry_Call can be accepted immediately
|
|
|
1052
|
|
|
1053 -- If the Acceptor is not callable, return False.
|
|
|
1054 -- If the rendezvous can start, initiate it.
|
|
|
1055 -- If the accept-body is trivial, also complete the rendezvous.
|
|
|
1056 -- If the acceptor is not ready, enqueue the call.
|
|
|
1057
|
|
|
1058 -- This should have a special case for Accept_Call and Accept_Trivial,
|
|
|
1059 -- so that we don't have the loop setup overhead, below.
|
|
|
1060
|
|
|
1061 -- The call state Done is used here and elsewhere to include both the
|
|
|
1062 -- case of normal successful completion, and the case of an exception
|
|
|
1063 -- being raised. The difference is that if an exception is raised no one
|
|
|
1064 -- will pay attention to the fact that State = Done. Instead the
|
|
|
1065 -- exception will be raised in Undefer_Abort, and control will skip past
|
|
|
1066 -- the place where we normally would resume from an entry call.
|
|
|
1067
|
|
|
1068 pragma Assert (not Queuing.Onqueue (Entry_Call));
|
|
|
1069
|
|
|
1070 -- We rely that the call is off-queue for protection, that the caller
|
|
|
1071 -- will not exit the Entry_Caller_Sleep, and so will not reuse the call
|
|
|
1072 -- record for another call. We rely on the Caller's lock for call State
|
|
|
1073 -- mod's.
|
|
|
1074
|
|
|
1075 -- If Acceptor.Terminate_Alternative is True, we need to lock Parent and
|
|
|
1076 -- Acceptor, in that order; otherwise, we only need a lock on Acceptor.
|
|
|
1077 -- However, we can't check Acceptor.Terminate_Alternative until Acceptor
|
|
|
1078 -- is locked. Therefore, we need to lock both. Attempts to avoid locking
|
|
|
1079 -- Parent tend to result in race conditions. It would work to unlock
|
|
|
1080 -- Parent immediately upon finding Acceptor.Terminate_Alternative to be
|
|
|
1081 -- False, but that violates the rule of properly nested locking (see
|
|
|
1082 -- System.Tasking).
|
|
|
1083
|
|
|
1084 STPO.Write_Lock (Parent);
|
|
|
1085 STPO.Write_Lock (Acceptor);
|
|
|
1086
|
|
|
1087 -- If the acceptor is not callable, abort the call and return False
|
|
|
1088
|
|
|
1089 if not Acceptor.Callable then
|
|
|
1090 STPO.Unlock (Acceptor);
|
|
|
1091 STPO.Unlock (Parent);
|
|
|
1092
|
|
|
1093 pragma Assert (Entry_Call.State < Done);
|
|
|
1094
|
|
|
1095 -- In case we are not the caller, set up the caller
|
|
|
1096 -- to raise Tasking_Error when it wakes up.
|
|
|
1097
|
|
|
1098 STPO.Write_Lock (Entry_Call.Self);
|
|
|
1099 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
|
|
|
1100 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
|
|
|
1101 STPO.Unlock (Entry_Call.Self);
|
|
|
1102
|
|
|
1103 return False;
|
|
|
1104 end if;
|
|
|
1105
|
|
|
1106 -- Try to serve the call immediately
|
|
|
1107
|
|
|
1108 if Acceptor.Open_Accepts /= null then
|
|
|
1109 for J in Acceptor.Open_Accepts'Range loop
|
|
|
1110 if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
|
|
|
1111
|
|
|
1112 -- Commit acceptor to rendezvous with us
|
|
|
1113
|
|
|
1114 Acceptor.Chosen_Index := J;
|
|
|
1115 Null_Body := Acceptor.Open_Accepts (J).Null_Body;
|
|
|
1116 Acceptor.Open_Accepts := null;
|
|
|
1117
|
|
|
1118 -- Prevent abort while call is being served
|
|
|
1119
|
|
|
1120 if Entry_Call.State = Now_Abortable then
|
|
|
1121 Entry_Call.State := Was_Abortable;
|
|
|
1122 end if;
|
|
|
1123
|
|
|
1124 if Acceptor.Terminate_Alternative then
|
|
|
1125
|
|
|
1126 -- Cancel terminate alternative. See matching code in
|
|
|
1127 -- Selective_Wait and Vulnerable_Complete_Master.
|
|
|
1128
|
|
|
1129 Acceptor.Terminate_Alternative := False;
|
|
|
1130 Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
|
|
|
1131
|
|
|
1132 if Acceptor.Awake_Count = 1 then
|
|
|
1133
|
|
|
1134 -- Notify parent that acceptor is awake
|
|
|
1135
|
|
|
1136 pragma Assert (Parent.Awake_Count > 0);
|
|
|
1137
|
|
|
1138 Parent.Awake_Count := Parent.Awake_Count + 1;
|
|
|
1139
|
|
|
1140 if Parent.Common.State = Master_Completion_Sleep
|
|
131
|
1141 and then Acceptor.Master_Of_Task = Parent.Master_Within
|
|
111
|
1142 then
|
|
|
1143 Parent.Common.Wait_Count :=
|
|
|
1144 Parent.Common.Wait_Count + 1;
|
|
|
1145 end if;
|
|
|
1146 end if;
|
|
|
1147 end if;
|
|
|
1148
|
|
|
1149 if Null_Body then
|
|
|
1150
|
|
|
1151 -- Rendezvous is over immediately
|
|
|
1152
|
|
|
1153 STPO.Wakeup (Acceptor, Acceptor_Sleep);
|
|
|
1154 STPO.Unlock (Acceptor);
|
|
|
1155 STPO.Unlock (Parent);
|
|
|
1156
|
|
|
1157 STPO.Write_Lock (Entry_Call.Self);
|
|
|
1158 Initialization.Wakeup_Entry_Caller
|
|
|
1159 (Self_ID, Entry_Call, Done);
|
|
|
1160 STPO.Unlock (Entry_Call.Self);
|
|
|
1161
|
|
|
1162 else
|
|
|
1163 Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
|
|
|
1164
|
|
|
1165 -- For terminate_alternative, acceptor may not be asleep
|
|
|
1166 -- yet, so we skip the wakeup
|
|
|
1167
|
|
|
1168 if Acceptor.Common.State /= Runnable then
|
|
|
1169 STPO.Wakeup (Acceptor, Acceptor_Sleep);
|
|
|
1170 end if;
|
|
|
1171
|
|
|
1172 STPO.Unlock (Acceptor);
|
|
|
1173 STPO.Unlock (Parent);
|
|
|
1174 end if;
|
|
|
1175
|
|
|
1176 return True;
|
|
|
1177 end if;
|
|
|
1178 end loop;
|
|
|
1179
|
|
|
1180 -- The acceptor is accepting, but not this entry
|
|
|
1181 end if;
|
|
|
1182
|
|
|
1183 -- If the acceptor was ready to accept this call,
|
|
|
1184 -- we would not have gotten this far, so now we should
|
|
|
1185 -- (re)enqueue the call, if the mode permits that.
|
|
|
1186
|
|
|
1187 -- If the call is timed, it may have timed out before the requeue,
|
|
|
1188 -- in the unusual case where the current accept has taken longer than
|
|
|
1189 -- the given delay. In that case the requeue is cancelled, and the
|
|
|
1190 -- outer timed call will be aborted.
|
|
|
1191
|
|
|
1192 if Entry_Call.Mode = Conditional_Call
|
|
|
1193 or else
|
|
|
1194 (Entry_Call.Mode = Timed_Call
|
|
|
1195 and then Entry_Call.With_Abort
|
|
|
1196 and then Entry_Call.Cancellation_Attempted)
|
|
|
1197 then
|
|
|
1198 STPO.Unlock (Acceptor);
|
|
|
1199 STPO.Unlock (Parent);
|
|
|
1200
|
|
|
1201 STPO.Write_Lock (Entry_Call.Self);
|
|
|
1202
|
|
|
1203 pragma Assert (Entry_Call.State >= Was_Abortable);
|
|
|
1204
|
|
|
1205 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
|
|
|
1206 STPO.Unlock (Entry_Call.Self);
|
|
|
1207
|
|
|
1208 else
|
|
|
1209 -- Timed_Call, Simple_Call, or Asynchronous_Call
|
|
|
1210
|
|
|
1211 Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
|
|
|
1212
|
|
|
1213 -- Update abortability of call
|
|
|
1214
|
|
|
1215 pragma Assert (Old_State < Done);
|
|
|
1216
|
|
|
1217 Entry_Call.State :=
|
|
|
1218 New_State (Entry_Call.With_Abort, Entry_Call.State);
|
|
|
1219
|
|
|
1220 STPO.Unlock (Acceptor);
|
|
|
1221 STPO.Unlock (Parent);
|
|
|
1222
|
|
|
1223 if Old_State /= Entry_Call.State
|
|
|
1224 and then Entry_Call.State = Now_Abortable
|
|
|
1225 and then Entry_Call.Mode /= Simple_Call
|
|
|
1226 and then Entry_Call.Self /= Self_ID
|
|
|
1227
|
|
|
1228 -- Asynchronous_Call or Conditional_Call
|
|
|
1229
|
|
|
1230 then
|
|
|
1231 -- Because of ATCB lock ordering rule
|
|
|
1232
|
|
|
1233 STPO.Write_Lock (Entry_Call.Self);
|
|
|
1234
|
|
|
1235 if Entry_Call.Self.Common.State = Async_Select_Sleep then
|
|
|
1236
|
|
|
1237 -- Caller may not yet have reached wait-point
|
|
|
1238
|
|
|
1239 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
|
|
|
1240 end if;
|
|
|
1241
|
|
|
1242 STPO.Unlock (Entry_Call.Self);
|
|
|
1243 end if;
|
|
|
1244 end if;
|
|
|
1245
|
|
|
1246 return True;
|
|
|
1247 end Task_Do_Or_Queue;
|
|
|
1248
|
|
|
1249 ---------------------
|
|
|
1250 -- Task_Entry_Call --
|
|
|
1251 ---------------------
|
|
|
1252
|
|
|
1253 procedure Task_Entry_Call
|
|
|
1254 (Acceptor : Task_Id;
|
|
|
1255 E : Task_Entry_Index;
|
|
|
1256 Uninterpreted_Data : System.Address;
|
|
|
1257 Mode : Call_Modes;
|
|
|
1258 Rendezvous_Successful : out Boolean)
|
|
|
1259 is
|
|
|
1260 Self_Id : constant Task_Id := STPO.Self;
|
|
|
1261 Entry_Call : Entry_Call_Link;
|
|
|
1262
|
|
|
1263 begin
|
|
|
1264 -- If pragma Detect_Blocking is active then Program_Error must be
|
|
|
1265 -- raised if this potentially blocking operation is called from a
|
|
|
1266 -- protected action.
|
|
|
1267
|
|
|
1268 if System.Tasking.Detect_Blocking
|
|
|
1269 and then Self_Id.Common.Protected_Action_Nesting > 0
|
|
|
1270 then
|
|
|
1271 raise Program_Error with
|
|
|
1272 "potentially blocking operation";
|
|
|
1273 end if;
|
|
|
1274
|
|
|
1275 if Mode = Simple_Call or else Mode = Conditional_Call then
|
|
|
1276 Call_Synchronous
|
|
|
1277 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
|
|
|
1278
|
|
|
1279 else
|
|
|
1280 -- This is an asynchronous call
|
|
|
1281
|
|
|
1282 -- Abort must already be deferred by the compiler-generated code.
|
|
|
1283 -- Without this, an abort that occurs between the time that this
|
|
|
1284 -- call is made and the time that the abortable part's cleanup
|
|
|
1285 -- handler is set up might miss the cleanup handler and leave the
|
|
|
1286 -- call pending.
|
|
|
1287
|
|
|
1288 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
|
|
|
1289 pragma Debug
|
|
|
1290 (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
|
|
|
1291 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
|
|
|
1292 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
|
|
|
1293 Entry_Call.Next := null;
|
|
|
1294 Entry_Call.Mode := Mode;
|
|
|
1295 Entry_Call.Cancellation_Attempted := False;
|
|
|
1296 Entry_Call.State := Not_Yet_Abortable;
|
|
|
1297 Entry_Call.E := Entry_Index (E);
|
|
|
1298 Entry_Call.Prio := Get_Priority (Self_Id);
|
|
|
1299 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
|
|
|
1300 Entry_Call.Called_Task := Acceptor;
|
|
|
1301 Entry_Call.Called_PO := Null_Address;
|
|
|
1302 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
|
|
|
1303 Entry_Call.With_Abort := True;
|
|
|
1304
|
|
|
1305 if Single_Lock then
|
|
|
1306 Lock_RTS;
|
|
|
1307 end if;
|
|
|
1308
|
|
|
1309 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
|
|
|
1310 STPO.Write_Lock (Self_Id);
|
|
|
1311 Utilities.Exit_One_ATC_Level (Self_Id);
|
|
|
1312 STPO.Unlock (Self_Id);
|
|
|
1313
|
|
|
1314 if Single_Lock then
|
|
|
1315 Unlock_RTS;
|
|
|
1316 end if;
|
|
|
1317
|
|
|
1318 Initialization.Undefer_Abort (Self_Id);
|
|
|
1319
|
|
|
1320 raise Tasking_Error;
|
|
|
1321 end if;
|
|
|
1322
|
|
|
1323 -- The following is special for async. entry calls. If the call was
|
|
|
1324 -- not queued abortably, we need to wait until it is before
|
|
|
1325 -- proceeding with the abortable part.
|
|
|
1326
|
|
|
1327 -- Wait_Until_Abortable can be called unconditionally here, but it is
|
|
|
1328 -- expensive.
|
|
|
1329
|
|
|
1330 if Entry_Call.State < Was_Abortable then
|
|
|
1331 Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
|
|
|
1332 end if;
|
|
|
1333
|
|
|
1334 if Single_Lock then
|
|
|
1335 Unlock_RTS;
|
|
|
1336 end if;
|
|
|
1337
|
|
|
1338 -- Note: following assignment needs to be atomic
|
|
|
1339
|
|
|
1340 Rendezvous_Successful := Entry_Call.State = Done;
|
|
|
1341 end if;
|
|
|
1342 end Task_Entry_Call;
|
|
|
1343
|
|
|
1344 -----------------------
|
|
|
1345 -- Task_Entry_Caller --
|
|
|
1346 -----------------------
|
|
|
1347
|
|
|
1348 function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
|
|
|
1349 Self_Id : constant Task_Id := STPO.Self;
|
|
|
1350 Entry_Call : Entry_Call_Link;
|
|
|
1351
|
|
|
1352 begin
|
|
|
1353 Entry_Call := Self_Id.Common.Call;
|
|
|
1354
|
|
|
1355 for Depth in 1 .. D loop
|
|
|
1356 Entry_Call := Entry_Call.Acceptor_Prev_Call;
|
|
|
1357 pragma Assert (Entry_Call /= null);
|
|
|
1358 end loop;
|
|
|
1359
|
|
|
1360 return Entry_Call.Self;
|
|
|
1361 end Task_Entry_Caller;
|
|
|
1362
|
|
|
1363 --------------------------
|
|
|
1364 -- Timed_Selective_Wait --
|
|
|
1365 --------------------------
|
|
|
1366
|
|
|
1367 procedure Timed_Selective_Wait
|
|
|
1368 (Open_Accepts : Accept_List_Access;
|
|
|
1369 Select_Mode : Select_Modes;
|
|
|
1370 Uninterpreted_Data : out System.Address;
|
|
|
1371 Timeout : Duration;
|
|
|
1372 Mode : Delay_Modes;
|
|
|
1373 Index : out Select_Index)
|
|
|
1374 is
|
|
|
1375 Self_Id : constant Task_Id := STPO.Self;
|
|
|
1376 Treatment : Select_Treatment;
|
|
|
1377 Entry_Call : Entry_Call_Link;
|
|
|
1378 Caller : Task_Id;
|
|
|
1379 Selection : Select_Index;
|
|
|
1380 Open_Alternative : Boolean;
|
|
|
1381 Timedout : Boolean := False;
|
|
|
1382 Yielded : Boolean := True;
|
|
|
1383
|
|
|
1384 begin
|
|
|
1385 pragma Assert (Select_Mode = Delay_Mode);
|
|
|
1386
|
|
|
1387 Initialization.Defer_Abort (Self_Id);
|
|
|
1388
|
|
|
1389 -- If we are aborted here, the effect will be pending
|
|
|
1390
|
|
|
1391 if Single_Lock then
|
|
|
1392 Lock_RTS;
|
|
|
1393 end if;
|
|
|
1394
|
|
|
1395 STPO.Write_Lock (Self_Id);
|
|
|
1396
|
|
|
1397 if not Self_Id.Callable then
|
|
|
1398 pragma Assert (Self_Id.Pending_ATC_Level = 0);
|
|
|
1399
|
|
|
1400 pragma Assert (Self_Id.Pending_Action);
|
|
|
1401
|
|
|
1402 STPO.Unlock (Self_Id);
|
|
|
1403
|
|
|
1404 if Single_Lock then
|
|
|
1405 Unlock_RTS;
|
|
|
1406 end if;
|
|
|
1407
|
|
|
1408 Initialization.Undefer_Abort (Self_Id);
|
|
|
1409
|
|
|
1410 -- Should never get here ???
|
|
|
1411
|
|
|
1412 pragma Assert (False);
|
|
|
1413 raise Standard'Abort_Signal;
|
|
|
1414 end if;
|
|
|
1415
|
|
|
1416 Uninterpreted_Data := Null_Address;
|
|
|
1417
|
|
|
1418 pragma Assert (Open_Accepts /= null);
|
|
|
1419
|
|
|
1420 Queuing.Select_Task_Entry_Call
|
|
|
1421 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
|
|
|
1422
|
|
|
1423 -- Determine the kind and disposition of the select
|
|
|
1424
|
|
|
1425 Treatment := Default_Treatment (Select_Mode);
|
|
|
1426 Self_Id.Chosen_Index := No_Rendezvous;
|
|
|
1427
|
|
|
1428 if Open_Alternative then
|
|
|
1429 if Entry_Call /= null then
|
|
|
1430 if Open_Accepts (Selection).Null_Body then
|
|
|
1431 Treatment := Accept_Alternative_Completed;
|
|
|
1432
|
|
|
1433 else
|
|
|
1434 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
|
|
|
1435 Treatment := Accept_Alternative_Selected;
|
|
|
1436 end if;
|
|
|
1437
|
|
|
1438 Self_Id.Chosen_Index := Selection;
|
|
|
1439
|
|
|
1440 elsif Treatment = No_Alternative_Open then
|
|
|
1441 Treatment := Accept_Alternative_Open;
|
|
|
1442 end if;
|
|
|
1443 end if;
|
|
|
1444
|
|
|
1445 -- Handle the select according to the disposition selected above
|
|
|
1446
|
|
|
1447 case Treatment is
|
|
|
1448 when Accept_Alternative_Selected =>
|
|
|
1449
|
|
|
1450 -- Ready to rendezvous. In this case the accept body is not
|
|
|
1451 -- Null_Body. Defer abort until it gets into the accept body.
|
|
|
1452
|
|
|
1453 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
|
|
|
1454 Initialization.Defer_Abort_Nestable (Self_Id);
|
|
|
1455 STPO.Unlock (Self_Id);
|
|
|
1456
|
|
|
1457 when Accept_Alternative_Completed =>
|
|
|
1458
|
|
|
1459 -- Rendezvous is over
|
|
|
1460
|
|
|
1461 STPO.Unlock (Self_Id);
|
|
|
1462 Caller := Entry_Call.Self;
|
|
|
1463
|
|
|
1464 STPO.Write_Lock (Caller);
|
|
|
1465 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
|
|
|
1466 STPO.Unlock (Caller);
|
|
|
1467
|
|
|
1468 when Accept_Alternative_Open =>
|
|
|
1469
|
|
|
1470 -- Wait for caller
|
|
|
1471
|
|
|
1472 Self_Id.Open_Accepts := Open_Accepts;
|
|
|
1473
|
|
|
1474 -- Wait for a normal call and a pending action until the
|
|
|
1475 -- Wakeup_Time is reached.
|
|
|
1476
|
|
|
1477 Self_Id.Common.State := Acceptor_Delay_Sleep;
|
|
|
1478
|
|
|
1479 -- Try to remove calls to Sleep in the loop below by letting the
|
|
|
1480 -- caller a chance of getting ready immediately, using Unlock
|
|
|
1481 -- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
|
|
|
1482
|
|
|
1483 if Single_Lock then
|
|
|
1484 Unlock_RTS;
|
|
|
1485 else
|
|
|
1486 Unlock (Self_Id);
|
|
|
1487 end if;
|
|
|
1488
|
|
|
1489 if Self_Id.Open_Accepts /= null then
|
|
|
1490 Yield;
|
|
|
1491 end if;
|
|
|
1492
|
|
|
1493 if Single_Lock then
|
|
|
1494 Lock_RTS;
|
|
|
1495 else
|
|
|
1496 Write_Lock (Self_Id);
|
|
|
1497 end if;
|
|
|
1498
|
|
|
1499 -- Check if this task has been aborted while the lock was released
|
|
|
1500
|
|
|
1501 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
|
|
|
1502 Self_Id.Open_Accepts := null;
|
|
|
1503 end if;
|
|
|
1504
|
|
|
1505 loop
|
|
|
1506 exit when Self_Id.Open_Accepts = null;
|
|
|
1507
|
|
|
1508 if Timedout then
|
|
|
1509 Sleep (Self_Id, Acceptor_Delay_Sleep);
|
|
|
1510 else
|
|
|
1511 STPO.Timed_Sleep (Self_Id, Timeout, Mode,
|
|
|
1512 Acceptor_Delay_Sleep, Timedout, Yielded);
|
|
|
1513 end if;
|
|
|
1514
|
|
|
1515 if Timedout then
|
|
|
1516 Self_Id.Open_Accepts := null;
|
|
|
1517 end if;
|
|
|
1518 end loop;
|
|
|
1519
|
|
|
1520 Self_Id.Common.State := Runnable;
|
|
|
1521
|
|
|
1522 -- Self_Id.Common.Call should already be updated by the Caller if
|
|
|
1523 -- not aborted. It might also be ready to do rendezvous even if
|
|
|
1524 -- this wakes up due to an abort. Therefore, if the call is not
|
|
|
1525 -- empty we need to do the rendezvous if the accept body is not
|
|
|
1526 -- Null_Body.
|
|
|
1527
|
|
|
1528 if Self_Id.Chosen_Index /= No_Rendezvous
|
|
|
1529 and then Self_Id.Common.Call /= null
|
|
|
1530 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
|
|
|
1531 then
|
|
|
1532 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
|
|
|
1533
|
|
|
1534 pragma Assert (Self_Id.Deferral_Level = 1);
|
|
|
1535
|
|
|
1536 Initialization.Defer_Abort_Nestable (Self_Id);
|
|
|
1537
|
|
|
1538 -- Leave abort deferred until the accept body
|
|
|
1539 end if;
|
|
|
1540
|
|
|
1541 STPO.Unlock (Self_Id);
|
|
|
1542
|
|
|
1543 when No_Alternative_Open =>
|
|
|
1544
|
|
|
1545 -- In this case, Index will be No_Rendezvous on return. We sleep
|
|
|
1546 -- for the time we need to.
|
|
|
1547
|
|
|
1548 -- Wait for a signal or timeout. A wakeup can be made
|
|
|
1549 -- for several reasons:
|
|
|
1550 -- 1) Delay is expired
|
|
|
1551 -- 2) Pending_Action needs to be checked
|
|
|
1552 -- (Abort, Priority change)
|
|
|
1553 -- 3) Spurious wakeup
|
|
|
1554
|
|
|
1555 Self_Id.Open_Accepts := null;
|
|
|
1556 Self_Id.Common.State := Acceptor_Delay_Sleep;
|
|
|
1557
|
|
|
1558 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep,
|
|
|
1559 Timedout, Yielded);
|
|
|
1560
|
|
|
1561 Self_Id.Common.State := Runnable;
|
|
|
1562
|
|
|
1563 STPO.Unlock (Self_Id);
|
|
|
1564
|
|
|
1565 when others =>
|
|
|
1566
|
|
|
1567 -- Should never get here
|
|
|
1568
|
|
|
1569 pragma Assert (False);
|
|
|
1570 null;
|
|
|
1571 end case;
|
|
|
1572
|
|
|
1573 if Single_Lock then
|
|
|
1574 Unlock_RTS;
|
|
|
1575 end if;
|
|
|
1576
|
|
|
1577 if not Yielded then
|
|
|
1578 Yield;
|
|
|
1579 end if;
|
|
|
1580
|
|
|
1581 -- Caller has been chosen
|
|
|
1582
|
|
|
1583 -- Self_Id.Common.Call should already be updated by the Caller
|
|
|
1584
|
|
|
1585 -- Self_Id.Chosen_Index should either be updated by the Caller
|
|
|
1586 -- or by Test_Selective_Wait
|
|
|
1587
|
|
|
1588 Index := Self_Id.Chosen_Index;
|
|
|
1589 Initialization.Undefer_Abort_Nestable (Self_Id);
|
|
|
1590
|
|
|
1591 -- Start rendezvous, if not already completed
|
|
|
1592 end Timed_Selective_Wait;
|
|
|
1593
|
|
|
1594 ---------------------------
|
|
|
1595 -- Timed_Task_Entry_Call --
|
|
|
1596 ---------------------------
|
|
|
1597
|
|
|
1598 procedure Timed_Task_Entry_Call
|
|
|
1599 (Acceptor : Task_Id;
|
|
|
1600 E : Task_Entry_Index;
|
|
|
1601 Uninterpreted_Data : System.Address;
|
|
|
1602 Timeout : Duration;
|
|
|
1603 Mode : Delay_Modes;
|
|
|
1604 Rendezvous_Successful : out Boolean)
|
|
|
1605 is
|
|
|
1606 Self_Id : constant Task_Id := STPO.Self;
|
|
|
1607 Level : ATC_Level;
|
|
|
1608 Entry_Call : Entry_Call_Link;
|
|
|
1609
|
|
|
1610 Yielded : Boolean;
|
|
|
1611 pragma Unreferenced (Yielded);
|
|
|
1612
|
|
|
1613 begin
|
|
|
1614 -- If pragma Detect_Blocking is active then Program_Error must be
|
|
|
1615 -- raised if this potentially blocking operation is called from a
|
|
|
1616 -- protected action.
|
|
|
1617
|
|
|
1618 if System.Tasking.Detect_Blocking
|
|
|
1619 and then Self_Id.Common.Protected_Action_Nesting > 0
|
|
|
1620 then
|
|
|
1621 raise Program_Error with
|
|
|
1622 "potentially blocking operation";
|
|
|
1623 end if;
|
|
|
1624
|
|
|
1625 Initialization.Defer_Abort (Self_Id);
|
|
|
1626 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
|
|
|
1627
|
|
|
1628 pragma Debug
|
|
|
1629 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
|
|
|
1630 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
|
|
|
1631
|
|
|
1632 Level := Self_Id.ATC_Nesting_Level;
|
|
|
1633 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
|
|
|
1634 Entry_Call.Next := null;
|
|
|
1635 Entry_Call.Mode := Timed_Call;
|
|
|
1636 Entry_Call.Cancellation_Attempted := False;
|
|
|
1637
|
|
|
1638 -- If this is a call made inside of an abort deferred region,
|
|
|
1639 -- the call should be never abortable.
|
|
|
1640
|
|
|
1641 Entry_Call.State :=
|
|
|
1642 (if Self_Id.Deferral_Level > 1
|
|
|
1643 then Never_Abortable
|
|
|
1644 else Now_Abortable);
|
|
|
1645
|
|
|
1646 Entry_Call.E := Entry_Index (E);
|
|
|
1647 Entry_Call.Prio := Get_Priority (Self_Id);
|
|
|
1648 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
|
|
|
1649 Entry_Call.Called_Task := Acceptor;
|
|
|
1650 Entry_Call.Called_PO := Null_Address;
|
|
|
1651 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
|
|
|
1652 Entry_Call.With_Abort := True;
|
|
|
1653
|
|
|
1654 -- Note: the caller will undefer abort on return (see WARNING above)
|
|
|
1655
|
|
|
1656 if Single_Lock then
|
|
|
1657 Lock_RTS;
|
|
|
1658 end if;
|
|
|
1659
|
|
|
1660 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
|
|
|
1661 STPO.Write_Lock (Self_Id);
|
|
|
1662 Utilities.Exit_One_ATC_Level (Self_Id);
|
|
|
1663 STPO.Unlock (Self_Id);
|
|
|
1664
|
|
|
1665 if Single_Lock then
|
|
|
1666 Unlock_RTS;
|
|
|
1667 end if;
|
|
|
1668
|
|
|
1669 Initialization.Undefer_Abort (Self_Id);
|
|
|
1670
|
|
|
1671 raise Tasking_Error;
|
|
|
1672 end if;
|
|
|
1673
|
|
|
1674 Write_Lock (Self_Id);
|
|
|
1675 Entry_Calls.Wait_For_Completion_With_Timeout
|
|
|
1676 (Entry_Call, Timeout, Mode, Yielded);
|
|
|
1677 Unlock (Self_Id);
|
|
|
1678
|
|
|
1679 if Single_Lock then
|
|
|
1680 Unlock_RTS;
|
|
|
1681 end if;
|
|
|
1682
|
|
|
1683 -- ??? Do we need to yield in case Yielded is False
|
|
|
1684
|
|
|
1685 Rendezvous_Successful := Entry_Call.State = Done;
|
|
|
1686 Initialization.Undefer_Abort (Self_Id);
|
|
|
1687 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
|
|
|
1688 end Timed_Task_Entry_Call;
|
|
|
1689
|
|
|
1690 -------------------
|
|
|
1691 -- Wait_For_Call --
|
|
|
1692 -------------------
|
|
|
1693
|
|
|
1694 procedure Wait_For_Call (Self_Id : Task_Id) is
|
|
|
1695 begin
|
|
|
1696 Self_Id.Common.State := Acceptor_Sleep;
|
|
|
1697
|
|
|
1698 -- Try to remove calls to Sleep in the loop below by letting the caller
|
|
|
1699 -- a chance of getting ready immediately, using Unlock & Yield.
|
|
|
1700 -- See similar action in Wait_For_Completion & Timed_Selective_Wait.
|
|
|
1701
|
|
|
1702 if Single_Lock then
|
|
|
1703 Unlock_RTS;
|
|
|
1704 else
|
|
|
1705 Unlock (Self_Id);
|
|
|
1706 end if;
|
|
|
1707
|
|
|
1708 if Self_Id.Open_Accepts /= null then
|
|
|
1709 Yield;
|
|
|
1710 end if;
|
|
|
1711
|
|
|
1712 if Single_Lock then
|
|
|
1713 Lock_RTS;
|
|
|
1714 else
|
|
|
1715 Write_Lock (Self_Id);
|
|
|
1716 end if;
|
|
|
1717
|
|
|
1718 -- Check if this task has been aborted while the lock was released
|
|
|
1719
|
|
|
1720 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
|
|
|
1721 Self_Id.Open_Accepts := null;
|
|
|
1722 end if;
|
|
|
1723
|
|
|
1724 loop
|
|
|
1725 exit when Self_Id.Open_Accepts = null;
|
|
|
1726 Sleep (Self_Id, Acceptor_Sleep);
|
|
|
1727 end loop;
|
|
|
1728
|
|
|
1729 Self_Id.Common.State := Runnable;
|
|
|
1730 end Wait_For_Call;
|
|
|
1731
|
|
|
1732 end System.Tasking.Rendezvous;
|
