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