Skip several gcc.dg/builtin-dynamic-object-size tests on hppa*-*-hpux*
[official-gcc.git] / gcc / ada / libgnarl / s-tasren.adb
blob956cb2607e9161aa499a62d89be16fd21a369a7a
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 -- --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
10 -- --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- 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 ------------------------------------------------------------------------------
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;
41 package body System.Tasking.Rendezvous is
43 package STPO renames System.Task_Primitives.Operations;
44 package POO renames Protected_Objects.Operations;
45 package POE renames Protected_Objects.Entries;
47 use Task_Primitives.Operations;
49 type Select_Treatment is (
50 Accept_Alternative_Selected, -- alternative with non-null body
51 Accept_Alternative_Completed, -- alternative with null body
52 Else_Selected,
53 Terminate_Selected,
54 Accept_Alternative_Open,
55 No_Alternative_Open);
57 ----------------
58 -- Local Data --
59 ----------------
61 Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
62 [Simple_Mode => No_Alternative_Open,
63 Else_Mode => Else_Selected,
64 Terminate_Mode => Terminate_Selected,
65 Delay_Mode => No_Alternative_Open];
67 New_State : constant array (Boolean, Entry_Call_State)
68 of Entry_Call_State :=
69 [True =>
70 [Never_Abortable => Never_Abortable,
71 Not_Yet_Abortable => Now_Abortable,
72 Was_Abortable => Now_Abortable,
73 Now_Abortable => Now_Abortable,
74 Done => Done,
75 Cancelled => Cancelled],
76 False =>
77 [Never_Abortable => Never_Abortable,
78 Not_Yet_Abortable => Not_Yet_Abortable,
79 Was_Abortable => Was_Abortable,
80 Now_Abortable => Now_Abortable,
81 Done => Done,
82 Cancelled => Cancelled]
85 -----------------------
86 -- Local Subprograms --
87 -----------------------
89 procedure Local_Defer_Abort (Self_Id : Task_Id) renames
90 System.Tasking.Initialization.Defer_Abort_Nestable;
92 procedure Local_Undefer_Abort (Self_Id : Task_Id) renames
93 System.Tasking.Initialization.Undefer_Abort_Nestable;
95 -- Florist defers abort around critical sections that make entry calls
96 -- to the Interrupt_Manager task, which violates the general rule about
97 -- top-level runtime system calls from abort-deferred regions. It is not
98 -- that this is unsafe, but when it occurs in "normal" programs it usually
99 -- means either the user is trying to do a potentially blocking operation
100 -- from within a protected object, or there is a runtime system/compiler
101 -- error that has failed to undefer an earlier abort deferral. Thus, for
102 -- debugging it may be wise to modify the above renamings to the
103 -- non-nestable forms.
105 procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id);
106 -- Internal version of Complete_Rendezvous, used to implement
107 -- Complete_Rendezvous and Exceptional_Complete_Rendezvous.
108 -- Should be called holding no locks, generally with abort
109 -- not yet deferred.
111 procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
112 pragma Inline (Boost_Priority);
113 -- Call this only with abort deferred and holding lock of Acceptor
115 procedure Call_Synchronous
116 (Acceptor : Task_Id;
117 E : Task_Entry_Index;
118 Uninterpreted_Data : System.Address;
119 Mode : Call_Modes;
120 Rendezvous_Successful : out Boolean);
121 pragma Inline (Call_Synchronous);
122 -- This call is used to make a simple or conditional entry call.
123 -- Called from Call_Simple and Task_Entry_Call.
125 procedure Setup_For_Rendezvous_With_Body
126 (Entry_Call : Entry_Call_Link;
127 Acceptor : Task_Id);
128 pragma Inline (Setup_For_Rendezvous_With_Body);
129 -- Call this only with abort deferred and holding lock of Acceptor. When
130 -- a rendezvous selected (ready for rendezvous) we need to save previous
131 -- caller and adjust the priority. Also we need to make this call not
132 -- Abortable (Cancellable) since the rendezvous has already been started.
134 procedure Wait_For_Call (Self_Id : Task_Id);
135 pragma Inline (Wait_For_Call);
136 -- Call this only with abort deferred and holding lock of Self_Id. An
137 -- accepting task goes into Sleep by calling this routine waiting for a
138 -- call from the caller or waiting for an abort. Make sure Self_Id is
139 -- locked before calling this routine.
141 -----------------
142 -- Accept_Call --
143 -----------------
145 procedure Accept_Call
146 (E : Task_Entry_Index;
147 Uninterpreted_Data : out System.Address)
149 Self_Id : constant Task_Id := STPO.Self;
150 Caller : Task_Id := null;
151 Open_Accepts : aliased Accept_List (1 .. 1);
152 Entry_Call : Entry_Call_Link;
154 begin
155 Initialization.Defer_Abort (Self_Id);
156 STPO.Write_Lock (Self_Id);
158 if not Self_Id.Callable then
159 pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task);
161 pragma Assert (Self_Id.Pending_Action);
163 STPO.Unlock (Self_Id);
164 Initialization.Undefer_Abort (Self_Id);
166 -- Should never get here ???
168 pragma Assert (Standard.False);
169 raise Standard'Abort_Signal;
170 end if;
172 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
174 if Entry_Call /= null then
175 Caller := Entry_Call.Self;
176 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
177 Uninterpreted_Data := Entry_Call.Uninterpreted_Data;
179 else
180 -- Wait for a caller
182 Open_Accepts (1).Null_Body := False;
183 Open_Accepts (1).S := E;
184 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
186 -- Wait for normal call
188 pragma Debug
189 (Debug.Trace (Self_Id, "Accept_Call: wait", 'R'));
190 Wait_For_Call (Self_Id);
192 pragma Assert (Self_Id.Open_Accepts = null);
194 if Self_Id.Common.Call /= null then
195 Caller := Self_Id.Common.Call.Self;
197 pragma Assert (Caller.ATC_Nesting_Level > Level_No_ATC_Occurring);
199 Uninterpreted_Data :=
200 Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
201 else
202 -- Case of an aborted task
204 Uninterpreted_Data := System.Null_Address;
205 end if;
206 end if;
208 -- Self_Id.Common.Call should already be updated by the Caller. On
209 -- return, we will start the rendezvous.
211 STPO.Unlock (Self_Id);
212 Initialization.Undefer_Abort (Self_Id);
213 end Accept_Call;
215 --------------------
216 -- Accept_Trivial --
217 --------------------
219 procedure Accept_Trivial (E : Task_Entry_Index) is
220 Self_Id : constant Task_Id := STPO.Self;
221 Caller : Task_Id := null;
222 Open_Accepts : aliased Accept_List (1 .. 1);
223 Entry_Call : Entry_Call_Link;
225 begin
226 Initialization.Defer_Abort_Nestable (Self_Id);
227 STPO.Write_Lock (Self_Id);
229 if not Self_Id.Callable then
230 pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task);
232 pragma Assert (Self_Id.Pending_Action);
234 STPO.Unlock (Self_Id);
235 Initialization.Undefer_Abort_Nestable (Self_Id);
237 -- Should never get here ???
239 pragma Assert (Standard.False);
240 raise Standard'Abort_Signal;
241 end if;
243 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
245 if Entry_Call = null then
247 -- Need to wait for entry call
249 Open_Accepts (1).Null_Body := True;
250 Open_Accepts (1).S := E;
251 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
253 pragma Debug
254 (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R'));
256 Wait_For_Call (Self_Id);
258 pragma Assert (Self_Id.Open_Accepts = null);
260 -- No need to do anything special here for pending abort.
261 -- Abort_Signal will be raised by Undefer on exit.
263 STPO.Unlock (Self_Id);
265 -- Found caller already waiting
267 else
268 pragma Assert (Entry_Call.State < Done);
270 STPO.Unlock (Self_Id);
271 Caller := Entry_Call.Self;
273 STPO.Write_Lock (Caller);
274 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
275 STPO.Unlock (Caller);
276 end if;
278 Initialization.Undefer_Abort_Nestable (Self_Id);
279 end Accept_Trivial;
281 --------------------
282 -- Boost_Priority --
283 --------------------
285 procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is
286 Caller : constant Task_Id := Call.Self;
287 Caller_Prio : constant System.Any_Priority := Get_Priority (Caller);
288 Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor);
289 begin
290 if Caller_Prio > Acceptor_Prio then
291 Call.Acceptor_Prev_Priority := Acceptor_Prio;
292 Set_Priority (Acceptor, Caller_Prio);
293 else
294 Call.Acceptor_Prev_Priority := Priority_Not_Boosted;
295 end if;
296 end Boost_Priority;
298 -----------------
299 -- Call_Simple --
300 -----------------
302 procedure Call_Simple
303 (Acceptor : Task_Id;
304 E : Task_Entry_Index;
305 Uninterpreted_Data : System.Address)
307 Rendezvous_Successful : Boolean;
309 begin
310 -- If pragma Detect_Blocking is active then Program_Error must be
311 -- raised if this potentially blocking operation is called from a
312 -- protected action.
314 if System.Tasking.Detect_Blocking
315 and then STPO.Self.Common.Protected_Action_Nesting > 0
316 then
317 raise Program_Error with
318 "potentially blocking operation";
319 end if;
321 Call_Synchronous
322 (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
323 end Call_Simple;
325 ----------------------
326 -- Call_Synchronous --
327 ----------------------
329 procedure Call_Synchronous
330 (Acceptor : Task_Id;
331 E : Task_Entry_Index;
332 Uninterpreted_Data : System.Address;
333 Mode : Call_Modes;
334 Rendezvous_Successful : out Boolean)
336 Self_Id : constant Task_Id := STPO.Self;
337 Level : ATC_Level;
338 Entry_Call : Entry_Call_Link;
340 begin
341 pragma Assert (Mode /= Asynchronous_Call);
343 Local_Defer_Abort (Self_Id);
344 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
345 pragma Debug
346 (Debug.Trace (Self_Id, "CS: entered ATC level: " &
347 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
348 Level := Self_Id.ATC_Nesting_Level;
349 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
350 Entry_Call.Next := null;
351 Entry_Call.Mode := Mode;
352 Entry_Call.Cancellation_Attempted := False;
354 -- If this is a call made inside of an abort deferred region,
355 -- the call should be never abortable.
357 Entry_Call.State :=
358 (if Self_Id.Deferral_Level > 1
359 then Never_Abortable
360 else Now_Abortable);
362 Entry_Call.E := Entry_Index (E);
363 Entry_Call.Prio := Get_Priority (Self_Id);
364 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
365 Entry_Call.Called_Task := Acceptor;
366 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
367 Entry_Call.With_Abort := True;
369 -- Note: the caller will undefer abort on return (see WARNING above)
371 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
372 STPO.Write_Lock (Self_Id);
373 Utilities.Exit_One_ATC_Level (Self_Id);
374 STPO.Unlock (Self_Id);
375 Local_Undefer_Abort (Self_Id);
377 raise Tasking_Error;
378 end if;
380 STPO.Write_Lock (Self_Id);
381 pragma Debug
382 (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R'));
383 Entry_Calls.Wait_For_Completion (Entry_Call);
384 pragma Debug
385 (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
386 Rendezvous_Successful := Entry_Call.State = Done;
387 STPO.Unlock (Self_Id);
388 Local_Undefer_Abort (Self_Id);
389 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
390 end Call_Synchronous;
392 --------------
393 -- Callable --
394 --------------
396 function Callable (T : Task_Id) return Boolean is
397 Result : Boolean;
398 Self_Id : constant Task_Id := STPO.Self;
400 begin
401 Initialization.Defer_Abort_Nestable (Self_Id);
402 STPO.Write_Lock (T);
403 Result := T.Callable;
404 STPO.Unlock (T);
405 Initialization.Undefer_Abort_Nestable (Self_Id);
407 return Result;
408 end Callable;
410 ----------------------------
411 -- Cancel_Task_Entry_Call --
412 ----------------------------
414 procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
415 begin
416 Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled);
417 end Cancel_Task_Entry_Call;
419 -------------------------
420 -- Complete_Rendezvous --
421 -------------------------
423 procedure Complete_Rendezvous is
424 begin
425 Local_Complete_Rendezvous (Ada.Exceptions.Null_Id);
426 end Complete_Rendezvous;
428 -------------------------------------
429 -- Exceptional_Complete_Rendezvous --
430 -------------------------------------
432 procedure Exceptional_Complete_Rendezvous
433 (Ex : Ada.Exceptions.Exception_Id)
435 procedure Internal_Reraise;
436 pragma No_Return (Internal_Reraise);
437 pragma Import (C, Internal_Reraise, "__gnat_reraise");
439 begin
440 Local_Complete_Rendezvous (Ex);
441 Internal_Reraise;
443 -- ??? Do we need to give precedence to Program_Error that might be
444 -- raised due to failure of finalization, over Tasking_Error from
445 -- failure of requeue?
446 end Exceptional_Complete_Rendezvous;
448 -------------------------------
449 -- Local_Complete_Rendezvous --
450 -------------------------------
452 procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is
453 Self_Id : constant Task_Id := STPO.Self;
454 Entry_Call : Entry_Call_Link := Self_Id.Common.Call;
455 Caller : Task_Id;
456 Called_PO : STPE.Protection_Entries_Access;
457 Acceptor_Prev_Priority : Integer;
459 Ceiling_Violation : Boolean;
461 use type Ada.Exceptions.Exception_Id;
462 procedure Transfer_Occurrence
463 (Target : Ada.Exceptions.Exception_Occurrence_Access;
464 Source : Ada.Exceptions.Exception_Occurrence);
465 pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
467 begin
468 -- The deferral level is critical here, since we want to raise an
469 -- exception or allow abort to take place, if there is an exception or
470 -- abort pending.
472 pragma Debug
473 (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R'));
475 Initialization.Defer_Abort (Self_Id);
477 -- We need to clean up any accepts which Self may have been serving when
478 -- it was aborted.
480 if Ex = Standard'Abort_Signal'Identity then
481 while Entry_Call /= null loop
482 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
484 -- All forms of accept make sure that the acceptor is not
485 -- completed, before accepting further calls, so that we
486 -- can be sure that no further calls are made after the
487 -- current calls are purged.
489 Caller := Entry_Call.Self;
491 -- Take write lock. This follows the lock precedence rule that
492 -- Caller may be locked while holding lock of Acceptor. Complete
493 -- the call abnormally, with exception.
495 STPO.Write_Lock (Caller);
496 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
497 STPO.Unlock (Caller);
498 Entry_Call := Entry_Call.Acceptor_Prev_Call;
499 end loop;
500 else
501 Caller := Entry_Call.Self;
503 if Entry_Call.Needs_Requeue then
505 -- We dare not lock Self_Id at the same time as Caller, for fear
506 -- of deadlock.
508 Entry_Call.Needs_Requeue := False;
509 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
511 if Entry_Call.Called_Task /= null then
513 -- Requeue to another task entry
515 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
516 Initialization.Undefer_Abort (Self_Id);
517 raise Tasking_Error;
518 end if;
519 else
520 -- Requeue to a protected entry
522 Called_PO := POE.To_Protection (Entry_Call.Called_PO);
523 STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation);
525 if Ceiling_Violation then
526 pragma Assert (Ex = Ada.Exceptions.Null_Id);
527 Entry_Call.Exception_To_Raise := Program_Error'Identity;
528 STPO.Write_Lock (Caller);
529 Initialization.Wakeup_Entry_Caller
530 (Self_Id, Entry_Call, Done);
531 STPO.Unlock (Caller);
533 else
534 POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call);
535 POO.PO_Service_Entries (Self_Id, Called_PO);
536 end if;
537 end if;
539 Entry_Calls.Reset_Priority
540 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
542 else
543 -- The call does not need to be requeued
545 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
546 Entry_Call.Exception_To_Raise := Ex;
547 STPO.Write_Lock (Caller);
549 -- Done with Caller locked to make sure that Wakeup is not lost
551 if Ex /= Ada.Exceptions.Null_Id then
552 Transfer_Occurrence
553 (Caller.Common.Compiler_Data.Current_Excep'Access,
554 Self_Id.Common.Compiler_Data.Current_Excep);
555 end if;
557 Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority;
558 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
560 STPO.Unlock (Caller);
561 Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
562 end if;
563 end if;
565 Initialization.Undefer_Abort (Self_Id);
566 end Local_Complete_Rendezvous;
568 -------------------------------------
569 -- Requeue_Protected_To_Task_Entry --
570 -------------------------------------
572 procedure Requeue_Protected_To_Task_Entry
573 (Object : STPE.Protection_Entries_Access;
574 Acceptor : Task_Id;
575 E : Task_Entry_Index;
576 With_Abort : Boolean)
578 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
579 begin
580 pragma Assert (STPO.Self.Deferral_Level > 0);
582 Entry_Call.E := Entry_Index (E);
583 Entry_Call.Called_Task := Acceptor;
584 Entry_Call.Called_PO := Null_Address;
585 Entry_Call.With_Abort := With_Abort;
586 Object.Call_In_Progress := null;
587 end Requeue_Protected_To_Task_Entry;
589 ------------------------
590 -- Requeue_Task_Entry --
591 ------------------------
593 procedure Requeue_Task_Entry
594 (Acceptor : Task_Id;
595 E : Task_Entry_Index;
596 With_Abort : Boolean)
598 Self_Id : constant Task_Id := STPO.Self;
599 Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
600 begin
601 Initialization.Defer_Abort (Self_Id);
602 Entry_Call.Needs_Requeue := True;
603 Entry_Call.With_Abort := With_Abort;
604 Entry_Call.E := Entry_Index (E);
605 Entry_Call.Called_Task := Acceptor;
606 Initialization.Undefer_Abort (Self_Id);
607 end Requeue_Task_Entry;
609 --------------------
610 -- Selective_Wait --
611 --------------------
613 procedure Selective_Wait
614 (Open_Accepts : Accept_List_Access;
615 Select_Mode : Select_Modes;
616 Uninterpreted_Data : out System.Address;
617 Index : out Select_Index)
619 Self_Id : constant Task_Id := STPO.Self;
620 Entry_Call : Entry_Call_Link;
621 Treatment : Select_Treatment;
622 Caller : Task_Id;
623 Selection : Select_Index;
624 Open_Alternative : Boolean;
626 begin
627 Initialization.Defer_Abort (Self_Id);
628 STPO.Write_Lock (Self_Id);
630 if not Self_Id.Callable then
631 pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task);
633 pragma Assert (Self_Id.Pending_Action);
635 STPO.Unlock (Self_Id);
637 -- ??? In some cases abort is deferred more than once. Need to
638 -- figure out why this happens.
640 if Self_Id.Deferral_Level > 1 then
641 Self_Id.Deferral_Level := 1;
642 end if;
644 Initialization.Undefer_Abort (Self_Id);
646 -- Should never get here ???
648 pragma Assert (Standard.False);
649 raise Standard'Abort_Signal;
650 end if;
652 pragma Assert (Open_Accepts /= null);
654 Uninterpreted_Data := Null_Address;
656 Queuing.Select_Task_Entry_Call
657 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
659 -- Determine the kind and disposition of the select
661 Treatment := Default_Treatment (Select_Mode);
662 Self_Id.Chosen_Index := No_Rendezvous;
664 if Open_Alternative then
665 if Entry_Call /= null then
666 if Open_Accepts (Selection).Null_Body then
667 Treatment := Accept_Alternative_Completed;
668 else
669 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
670 Treatment := Accept_Alternative_Selected;
671 end if;
673 Self_Id.Chosen_Index := Selection;
675 elsif Treatment = No_Alternative_Open then
676 Treatment := Accept_Alternative_Open;
677 end if;
678 end if;
680 -- Handle the select according to the disposition selected above
682 case Treatment is
683 when Accept_Alternative_Selected =>
685 -- Ready to rendezvous
687 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
689 -- In this case the accept body is not Null_Body. Defer abort
690 -- until it gets into the accept body. The compiler has inserted
691 -- a call to Abort_Undefer as part of the entry expansion.
693 pragma Assert (Self_Id.Deferral_Level = 1);
695 Initialization.Defer_Abort_Nestable (Self_Id);
696 STPO.Unlock (Self_Id);
698 when Accept_Alternative_Completed =>
700 -- Accept body is null, so rendezvous is over immediately
702 STPO.Unlock (Self_Id);
703 Caller := Entry_Call.Self;
705 STPO.Write_Lock (Caller);
706 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
707 STPO.Unlock (Caller);
709 when Accept_Alternative_Open =>
711 -- Wait for caller
713 Self_Id.Open_Accepts := Open_Accepts;
714 pragma Debug
715 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
717 Wait_For_Call (Self_Id);
719 pragma Assert (Self_Id.Open_Accepts = null);
721 -- Self_Id.Common.Call should already be updated by the Caller if
722 -- not aborted. It might also be ready to do rendezvous even if
723 -- this wakes up due to an abort. Therefore, if the call is not
724 -- empty we need to do the rendezvous if the accept body is not
725 -- Null_Body.
727 -- Aren't the first two conditions below redundant???
729 if Self_Id.Chosen_Index /= No_Rendezvous
730 and then Self_Id.Common.Call /= null
731 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
732 then
733 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
735 pragma Assert
736 (Self_Id.Deferral_Level = 1
737 or else
738 (Self_Id.Deferral_Level = 0
739 and then not Restrictions.Abort_Allowed));
741 Initialization.Defer_Abort_Nestable (Self_Id);
743 -- Leave abort deferred until the accept body
744 -- The compiler has inserted a call to Abort_Undefer as part of
745 -- the entry expansion.
746 end if;
748 STPO.Unlock (Self_Id);
750 when Else_Selected =>
751 pragma Assert (Self_Id.Open_Accepts = null);
753 STPO.Unlock (Self_Id);
755 when Terminate_Selected =>
757 -- Terminate alternative is open
759 Self_Id.Open_Accepts := Open_Accepts;
760 Self_Id.Common.State := Acceptor_Sleep;
762 -- Notify ancestors that this task is on a terminate alternative
764 STPO.Unlock (Self_Id);
765 Utilities.Make_Passive (Self_Id, Task_Completed => False);
766 STPO.Write_Lock (Self_Id);
768 -- Wait for normal entry call or termination
770 Wait_For_Call (Self_Id);
772 pragma Assert (Self_Id.Open_Accepts = null);
774 if Self_Id.Terminate_Alternative then
776 -- An entry call should have reset this to False, so we must be
777 -- aborted. We cannot be in an async. select, since that is not
778 -- legal, so the abort must be of the entire task. Therefore,
779 -- we do not need to cancel the terminate alternative. The
780 -- cleanup will be done in Complete_Master.
782 pragma Assert
783 (Self_Id.Pending_ATC_Level = Level_Completed_Task);
784 pragma Assert (Self_Id.Awake_Count = 0);
786 STPO.Unlock (Self_Id);
788 Index := Self_Id.Chosen_Index;
789 Initialization.Undefer_Abort_Nestable (Self_Id);
791 if Self_Id.Pending_Action then
792 Initialization.Do_Pending_Action (Self_Id);
793 end if;
795 return;
797 else
798 -- Self_Id.Common.Call and Self_Id.Chosen_Index
799 -- should already be updated by the Caller.
801 if Self_Id.Chosen_Index /= No_Rendezvous
802 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
803 then
804 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
806 pragma Assert (Self_Id.Deferral_Level = 1);
808 -- We need an extra defer here, to keep abort
809 -- deferred until we get into the accept body
810 -- The compiler has inserted a call to Abort_Undefer as part
811 -- of the entry expansion.
813 Initialization.Defer_Abort_Nestable (Self_Id);
814 end if;
815 end if;
817 STPO.Unlock (Self_Id);
819 when No_Alternative_Open =>
821 -- In this case, Index will be No_Rendezvous on return, which
822 -- should cause a Program_Error if it is not a Delay_Mode.
824 -- If delay alternative exists (Delay_Mode) we should suspend
825 -- until the delay expires.
827 Self_Id.Open_Accepts := null;
829 if Select_Mode = Delay_Mode then
830 Self_Id.Common.State := Delay_Sleep;
832 loop
833 exit when
834 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
835 Sleep (Self_Id, Delay_Sleep);
836 end loop;
838 Self_Id.Common.State := Runnable;
839 STPO.Unlock (Self_Id);
841 else
842 STPO.Unlock (Self_Id);
843 Initialization.Undefer_Abort (Self_Id);
844 raise Program_Error with "entry call not a delay mode";
845 end if;
846 end case;
848 -- Caller has been chosen
850 -- Self_Id.Common.Call should already be updated by the Caller.
852 -- Self_Id.Chosen_Index should either be updated by the Caller
853 -- or by Test_Selective_Wait.
855 -- On return, we sill start rendezvous unless the accept body is
856 -- null. In the latter case, we will have already completed the RV.
858 Index := Self_Id.Chosen_Index;
859 Initialization.Undefer_Abort_Nestable (Self_Id);
860 end Selective_Wait;
862 ------------------------------------
863 -- Setup_For_Rendezvous_With_Body --
864 ------------------------------------
866 procedure Setup_For_Rendezvous_With_Body
867 (Entry_Call : Entry_Call_Link;
868 Acceptor : Task_Id) is
869 begin
870 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
871 Acceptor.Common.Call := Entry_Call;
873 if Entry_Call.State = Now_Abortable then
874 Entry_Call.State := Was_Abortable;
875 end if;
877 Boost_Priority (Entry_Call, Acceptor);
878 end Setup_For_Rendezvous_With_Body;
880 ----------------
881 -- Task_Count --
882 ----------------
884 function Task_Count (E : Task_Entry_Index) return Natural is
885 Self_Id : constant Task_Id := STPO.Self;
886 Return_Count : Natural;
888 begin
889 Initialization.Defer_Abort (Self_Id);
890 STPO.Write_Lock (Self_Id);
891 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
892 STPO.Unlock (Self_Id);
893 Initialization.Undefer_Abort (Self_Id);
895 return Return_Count;
896 end Task_Count;
898 ----------------------
899 -- Task_Do_Or_Queue --
900 ----------------------
902 function Task_Do_Or_Queue
903 (Self_ID : Task_Id;
904 Entry_Call : Entry_Call_Link) return Boolean
906 E : constant Task_Entry_Index :=
907 Task_Entry_Index (Entry_Call.E);
908 Old_State : constant Entry_Call_State := Entry_Call.State;
909 Acceptor : constant Task_Id := Entry_Call.Called_Task;
910 Parent : constant Task_Id := Acceptor.Common.Parent;
911 Null_Body : Boolean;
913 begin
914 -- Find out whether Entry_Call can be accepted immediately
916 -- If the Acceptor is not callable, return False.
917 -- If the rendezvous can start, initiate it.
918 -- If the accept-body is trivial, also complete the rendezvous.
919 -- If the acceptor is not ready, enqueue the call.
921 -- This should have a special case for Accept_Call and Accept_Trivial,
922 -- so that we don't have the loop setup overhead, below.
924 -- The call state Done is used here and elsewhere to include both the
925 -- case of normal successful completion, and the case of an exception
926 -- being raised. The difference is that if an exception is raised no one
927 -- will pay attention to the fact that State = Done. Instead the
928 -- exception will be raised in Undefer_Abort, and control will skip past
929 -- the place where we normally would resume from an entry call.
931 pragma Assert (not Queuing.Onqueue (Entry_Call));
933 -- We rely that the call is off-queue for protection, that the caller
934 -- will not exit the Entry_Caller_Sleep, and so will not reuse the call
935 -- record for another call. We rely on the Caller's lock for call State
936 -- mod's.
938 -- If Acceptor.Terminate_Alternative is True, we need to lock Parent and
939 -- Acceptor, in that order; otherwise, we only need a lock on Acceptor.
940 -- However, we can't check Acceptor.Terminate_Alternative until Acceptor
941 -- is locked. Therefore, we need to lock both. Attempts to avoid locking
942 -- Parent tend to result in race conditions. It would work to unlock
943 -- Parent immediately upon finding Acceptor.Terminate_Alternative to be
944 -- False, but that violates the rule of properly nested locking (see
945 -- System.Tasking).
947 STPO.Write_Lock (Parent);
948 STPO.Write_Lock (Acceptor);
950 -- If the acceptor is not callable, abort the call and return False
952 if not Acceptor.Callable then
953 STPO.Unlock (Acceptor);
954 STPO.Unlock (Parent);
956 pragma Assert (Entry_Call.State < Done);
958 -- In case we are not the caller, set up the caller
959 -- to raise Tasking_Error when it wakes up.
961 STPO.Write_Lock (Entry_Call.Self);
962 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
963 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
964 STPO.Unlock (Entry_Call.Self);
966 return False;
967 end if;
969 -- Try to serve the call immediately
971 if Acceptor.Open_Accepts /= null then
972 for J in Acceptor.Open_Accepts'Range loop
973 if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
975 -- Commit acceptor to rendezvous with us
977 Acceptor.Chosen_Index := J;
978 Null_Body := Acceptor.Open_Accepts (J).Null_Body;
979 Acceptor.Open_Accepts := null;
981 -- Prevent abort while call is being served
983 if Entry_Call.State = Now_Abortable then
984 Entry_Call.State := Was_Abortable;
985 end if;
987 if Acceptor.Terminate_Alternative then
989 -- Cancel terminate alternative. See matching code in
990 -- Selective_Wait and Vulnerable_Complete_Master.
992 Acceptor.Terminate_Alternative := False;
993 Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
995 if Acceptor.Awake_Count = 1 then
997 -- Notify parent that acceptor is awake
999 pragma Assert (Parent.Awake_Count > 0);
1001 Parent.Awake_Count := Parent.Awake_Count + 1;
1003 if Parent.Common.State = Master_Completion_Sleep
1004 and then Acceptor.Master_Of_Task = Parent.Master_Within
1005 then
1006 Parent.Common.Wait_Count :=
1007 Parent.Common.Wait_Count + 1;
1008 end if;
1009 end if;
1010 end if;
1012 if Null_Body then
1014 -- Rendezvous is over immediately
1016 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1017 STPO.Unlock (Acceptor);
1018 STPO.Unlock (Parent);
1020 STPO.Write_Lock (Entry_Call.Self);
1021 Initialization.Wakeup_Entry_Caller
1022 (Self_ID, Entry_Call, Done);
1023 STPO.Unlock (Entry_Call.Self);
1025 else
1026 Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1028 -- For terminate_alternative, acceptor may not be asleep
1029 -- yet, so we skip the wakeup
1031 if Acceptor.Common.State /= Runnable then
1032 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1033 end if;
1035 STPO.Unlock (Acceptor);
1036 STPO.Unlock (Parent);
1037 end if;
1039 return True;
1040 end if;
1041 end loop;
1043 -- The acceptor is accepting, but not this entry
1044 end if;
1046 -- If the acceptor was ready to accept this call,
1047 -- we would not have gotten this far, so now we should
1048 -- (re)enqueue the call, if the mode permits that.
1050 -- If the call is timed, it may have timed out before the requeue,
1051 -- in the unusual case where the current accept has taken longer than
1052 -- the given delay. In that case the requeue is cancelled, and the
1053 -- outer timed call will be aborted.
1055 if Entry_Call.Mode = Conditional_Call
1056 or else
1057 (Entry_Call.Mode = Timed_Call
1058 and then Entry_Call.With_Abort
1059 and then Entry_Call.Cancellation_Attempted)
1060 then
1061 STPO.Unlock (Acceptor);
1062 STPO.Unlock (Parent);
1064 STPO.Write_Lock (Entry_Call.Self);
1066 pragma Assert (Entry_Call.State >= Was_Abortable);
1068 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1069 STPO.Unlock (Entry_Call.Self);
1071 else
1072 -- Timed_Call, Simple_Call, or Asynchronous_Call
1074 Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1076 -- Update abortability of call
1078 pragma Assert (Old_State < Done);
1080 Entry_Call.State :=
1081 New_State (Entry_Call.With_Abort, Entry_Call.State);
1083 STPO.Unlock (Acceptor);
1084 STPO.Unlock (Parent);
1086 if Old_State /= Entry_Call.State
1087 and then Entry_Call.State = Now_Abortable
1088 and then Entry_Call.Mode /= Simple_Call
1089 and then Entry_Call.Self /= Self_ID
1091 -- Asynchronous_Call or Conditional_Call
1093 then
1094 -- Because of ATCB lock ordering rule
1096 STPO.Write_Lock (Entry_Call.Self);
1098 if Entry_Call.Self.Common.State = Async_Select_Sleep then
1100 -- Caller may not yet have reached wait-point
1102 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1103 end if;
1105 STPO.Unlock (Entry_Call.Self);
1106 end if;
1107 end if;
1109 return True;
1110 end Task_Do_Or_Queue;
1112 ---------------------
1113 -- Task_Entry_Call --
1114 ---------------------
1116 procedure Task_Entry_Call
1117 (Acceptor : Task_Id;
1118 E : Task_Entry_Index;
1119 Uninterpreted_Data : System.Address;
1120 Mode : Call_Modes;
1121 Rendezvous_Successful : out Boolean)
1123 Self_Id : constant Task_Id := STPO.Self;
1124 Entry_Call : Entry_Call_Link;
1126 begin
1127 -- If pragma Detect_Blocking is active then Program_Error must be
1128 -- raised if this potentially blocking operation is called from a
1129 -- protected action.
1131 if System.Tasking.Detect_Blocking
1132 and then Self_Id.Common.Protected_Action_Nesting > 0
1133 then
1134 raise Program_Error with
1135 "potentially blocking operation";
1136 end if;
1138 if Mode = Simple_Call or else Mode = Conditional_Call then
1139 Call_Synchronous
1140 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1142 else
1143 -- This is an asynchronous call
1145 -- Abort must already be deferred by the compiler-generated code.
1146 -- Without this, an abort that occurs between the time that this
1147 -- call is made and the time that the abortable part's cleanup
1148 -- handler is set up might miss the cleanup handler and leave the
1149 -- call pending.
1151 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1152 pragma Debug
1153 (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1154 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1155 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1156 Entry_Call.Next := null;
1157 Entry_Call.Mode := Mode;
1158 Entry_Call.Cancellation_Attempted := False;
1159 Entry_Call.State := Not_Yet_Abortable;
1160 Entry_Call.E := Entry_Index (E);
1161 Entry_Call.Prio := Get_Priority (Self_Id);
1162 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1163 Entry_Call.Called_Task := Acceptor;
1164 Entry_Call.Called_PO := Null_Address;
1165 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1166 Entry_Call.With_Abort := True;
1168 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1169 STPO.Write_Lock (Self_Id);
1170 Utilities.Exit_One_ATC_Level (Self_Id);
1171 STPO.Unlock (Self_Id);
1172 Initialization.Undefer_Abort (Self_Id);
1174 raise Tasking_Error;
1175 end if;
1177 -- The following is special for async. entry calls. If the call was
1178 -- not queued abortably, we need to wait until it is before
1179 -- proceeding with the abortable part.
1181 -- Wait_Until_Abortable can be called unconditionally here, but it is
1182 -- expensive.
1184 if Entry_Call.State < Was_Abortable then
1185 Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1186 end if;
1188 -- Note: following assignment needs to be atomic
1190 Rendezvous_Successful := Entry_Call.State = Done;
1191 end if;
1192 end Task_Entry_Call;
1194 -----------------------
1195 -- Task_Entry_Caller --
1196 -----------------------
1198 function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1199 Self_Id : constant Task_Id := STPO.Self;
1200 Entry_Call : Entry_Call_Link;
1202 begin
1203 Entry_Call := Self_Id.Common.Call;
1205 for Depth in 1 .. D loop
1206 Entry_Call := Entry_Call.Acceptor_Prev_Call;
1207 pragma Assert (Entry_Call /= null);
1208 end loop;
1210 return Entry_Call.Self;
1211 end Task_Entry_Caller;
1213 --------------------------
1214 -- Timed_Selective_Wait --
1215 --------------------------
1217 procedure Timed_Selective_Wait
1218 (Open_Accepts : Accept_List_Access;
1219 Select_Mode : Select_Modes;
1220 Uninterpreted_Data : out System.Address;
1221 Timeout : Duration;
1222 Mode : Delay_Modes;
1223 Index : out Select_Index)
1225 Self_Id : constant Task_Id := STPO.Self;
1226 Treatment : Select_Treatment;
1227 Entry_Call : Entry_Call_Link;
1228 Caller : Task_Id;
1229 Selection : Select_Index;
1230 Open_Alternative : Boolean;
1231 Timedout : Boolean := False;
1232 Yielded : Boolean := True;
1234 begin
1235 pragma Assert (Select_Mode = Delay_Mode);
1237 Initialization.Defer_Abort (Self_Id);
1239 -- If we are aborted here, the effect will be pending
1241 STPO.Write_Lock (Self_Id);
1243 if not Self_Id.Callable then
1244 pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task);
1246 pragma Assert (Self_Id.Pending_Action);
1248 STPO.Unlock (Self_Id);
1249 Initialization.Undefer_Abort (Self_Id);
1251 -- Should never get here ???
1253 pragma Assert (Standard.False);
1254 raise Standard'Abort_Signal;
1255 end if;
1257 Uninterpreted_Data := Null_Address;
1259 pragma Assert (Open_Accepts /= null);
1261 Queuing.Select_Task_Entry_Call
1262 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1264 -- Determine the kind and disposition of the select
1266 Treatment := Default_Treatment (Select_Mode);
1267 Self_Id.Chosen_Index := No_Rendezvous;
1269 if Open_Alternative then
1270 if Entry_Call /= null then
1271 if Open_Accepts (Selection).Null_Body then
1272 Treatment := Accept_Alternative_Completed;
1274 else
1275 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1276 Treatment := Accept_Alternative_Selected;
1277 end if;
1279 Self_Id.Chosen_Index := Selection;
1281 elsif Treatment = No_Alternative_Open then
1282 Treatment := Accept_Alternative_Open;
1283 end if;
1284 end if;
1286 -- Handle the select according to the disposition selected above
1288 case Treatment is
1289 when Accept_Alternative_Selected =>
1291 -- Ready to rendezvous. In this case the accept body is not
1292 -- Null_Body. Defer abort until it gets into the accept body.
1294 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1295 Initialization.Defer_Abort_Nestable (Self_Id);
1296 STPO.Unlock (Self_Id);
1298 when Accept_Alternative_Completed =>
1300 -- Rendezvous is over
1302 STPO.Unlock (Self_Id);
1303 Caller := Entry_Call.Self;
1305 STPO.Write_Lock (Caller);
1306 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1307 STPO.Unlock (Caller);
1309 when Accept_Alternative_Open =>
1311 -- Wait for caller
1313 Self_Id.Open_Accepts := Open_Accepts;
1315 -- Wait for a normal call and a pending action until the
1316 -- Wakeup_Time is reached.
1318 Self_Id.Common.State := Acceptor_Delay_Sleep;
1320 -- Try to remove calls to Sleep in the loop below by letting the
1321 -- caller a chance of getting ready immediately, using Unlock
1322 -- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
1324 Unlock (Self_Id);
1326 if Self_Id.Open_Accepts /= null then
1327 Yield;
1328 end if;
1330 Write_Lock (Self_Id);
1332 -- Check if this task has been aborted while the lock was released
1334 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1335 Self_Id.Open_Accepts := null;
1336 end if;
1338 loop
1339 exit when Self_Id.Open_Accepts = null;
1341 if Timedout then
1342 Sleep (Self_Id, Acceptor_Delay_Sleep);
1343 else
1344 STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1345 Acceptor_Delay_Sleep, Timedout, Yielded);
1346 end if;
1348 if Timedout then
1349 Self_Id.Open_Accepts := null;
1350 end if;
1351 end loop;
1353 Self_Id.Common.State := Runnable;
1355 -- Self_Id.Common.Call should already be updated by the Caller if
1356 -- not aborted. It might also be ready to do rendezvous even if
1357 -- this wakes up due to an abort. Therefore, if the call is not
1358 -- empty we need to do the rendezvous if the accept body is not
1359 -- Null_Body.
1361 if Self_Id.Chosen_Index /= No_Rendezvous
1362 and then Self_Id.Common.Call /= null
1363 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1364 then
1365 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1367 pragma Assert (Self_Id.Deferral_Level = 1);
1369 Initialization.Defer_Abort_Nestable (Self_Id);
1371 -- Leave abort deferred until the accept body
1372 end if;
1374 STPO.Unlock (Self_Id);
1376 when No_Alternative_Open =>
1378 -- In this case, Index will be No_Rendezvous on return. We sleep
1379 -- for the time we need to.
1381 -- Wait for a signal or timeout. A wakeup can be made
1382 -- for several reasons:
1383 -- 1) Delay is expired
1384 -- 2) Pending_Action needs to be checked
1385 -- (Abort, Priority change)
1386 -- 3) Spurious wakeup
1388 Self_Id.Open_Accepts := null;
1389 Self_Id.Common.State := Acceptor_Delay_Sleep;
1391 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep,
1392 Timedout, Yielded);
1394 Self_Id.Common.State := Runnable;
1396 STPO.Unlock (Self_Id);
1398 when others =>
1400 -- Should never get here
1402 pragma Assert (Standard.False);
1403 null;
1404 end case;
1406 if not Yielded then
1407 Yield;
1408 end if;
1410 -- Caller has been chosen
1412 -- Self_Id.Common.Call should already be updated by the Caller
1414 -- Self_Id.Chosen_Index should either be updated by the Caller
1415 -- or by Test_Selective_Wait
1417 Index := Self_Id.Chosen_Index;
1418 Initialization.Undefer_Abort_Nestable (Self_Id);
1420 -- Start rendezvous, if not already completed
1421 end Timed_Selective_Wait;
1423 ---------------------------
1424 -- Timed_Task_Entry_Call --
1425 ---------------------------
1427 procedure Timed_Task_Entry_Call
1428 (Acceptor : Task_Id;
1429 E : Task_Entry_Index;
1430 Uninterpreted_Data : System.Address;
1431 Timeout : Duration;
1432 Mode : Delay_Modes;
1433 Rendezvous_Successful : out Boolean)
1435 Self_Id : constant Task_Id := STPO.Self;
1436 Level : ATC_Level;
1437 Entry_Call : Entry_Call_Link;
1439 Yielded : Boolean;
1441 begin
1442 -- If pragma Detect_Blocking is active then Program_Error must be
1443 -- raised if this potentially blocking operation is called from a
1444 -- protected action.
1446 if System.Tasking.Detect_Blocking
1447 and then Self_Id.Common.Protected_Action_Nesting > 0
1448 then
1449 raise Program_Error with
1450 "potentially blocking operation";
1451 end if;
1453 Initialization.Defer_Abort_Nestable (Self_Id);
1454 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1456 pragma Debug
1457 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1458 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1460 Level := Self_Id.ATC_Nesting_Level;
1461 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1462 Entry_Call.Next := null;
1463 Entry_Call.Mode := Timed_Call;
1464 Entry_Call.Cancellation_Attempted := False;
1466 -- If this is a call made inside of an abort deferred region,
1467 -- the call should be never abortable.
1469 Entry_Call.State :=
1470 (if Self_Id.Deferral_Level > 1
1471 then Never_Abortable
1472 else Now_Abortable);
1474 Entry_Call.E := Entry_Index (E);
1475 Entry_Call.Prio := Get_Priority (Self_Id);
1476 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1477 Entry_Call.Called_Task := Acceptor;
1478 Entry_Call.Called_PO := Null_Address;
1479 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1480 Entry_Call.With_Abort := True;
1482 -- Note: the caller will undefer abort on return (see WARNING above)
1484 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1485 STPO.Write_Lock (Self_Id);
1486 Utilities.Exit_One_ATC_Level (Self_Id);
1487 STPO.Unlock (Self_Id);
1488 Initialization.Undefer_Abort_Nestable (Self_Id);
1490 raise Tasking_Error;
1491 end if;
1493 Write_Lock (Self_Id);
1494 Entry_Calls.Wait_For_Completion_With_Timeout
1495 (Entry_Call, Timeout, Mode, Yielded);
1496 Unlock (Self_Id);
1498 -- ??? Do we need to yield in case Yielded is False
1500 Rendezvous_Successful := Entry_Call.State = Done;
1501 Initialization.Undefer_Abort_Nestable (Self_Id);
1502 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1503 end Timed_Task_Entry_Call;
1505 -------------------
1506 -- Wait_For_Call --
1507 -------------------
1509 procedure Wait_For_Call (Self_Id : Task_Id) is
1510 begin
1511 Self_Id.Common.State := Acceptor_Sleep;
1513 -- Try to remove calls to Sleep in the loop below by letting the caller
1514 -- a chance of getting ready immediately, using Unlock & Yield.
1515 -- See similar action in Wait_For_Completion & Timed_Selective_Wait.
1517 Unlock (Self_Id);
1519 if Self_Id.Open_Accepts /= null then
1520 Yield;
1521 end if;
1523 Write_Lock (Self_Id);
1525 -- Check if this task has been aborted while the lock was released
1527 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1528 Self_Id.Open_Accepts := null;
1529 end if;
1531 loop
1532 exit when Self_Id.Open_Accepts = null;
1533 Sleep (Self_Id, Acceptor_Sleep);
1534 end loop;
1536 Self_Id.Common.State := Runnable;
1537 end Wait_For_Call;
1539 end System.Tasking.Rendezvous;