1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . R E N D E Z V O U S --
9 -- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
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 2, or (at your option) any later ver- --
14 -- sion. GNARL 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
35 -- Used for Exception_ID
37 -- Transfer_Occurrence
40 with System
.Task_Primitives
.Operations
;
41 -- used for Get_Priority
49 with System
.Tasking
.Entry_Calls
;
50 -- Used for Wait_For_Completion
51 -- Wait_For_Completion_With_Timeout
52 -- Wait_Until_Abortable
54 with System
.Tasking
.Initialization
;
55 -- used for Defer_Abort
57 -- Poll_Base_Priority_Change
59 with System
.Tasking
.Queuing
;
62 -- Select_Task_Entry_Call
65 with System
.Tasking
.Utilities
;
66 -- used for Check_Exception
68 -- Wakeup_Entry_Caller
70 with System
.Tasking
.Protected_Objects
.Operations
;
71 -- used for PO_Do_Or_Queue
76 with System
.Tasking
.Debug
;
79 with System
.Parameters
;
80 -- used for Single_Lock
83 with System
.Traces
.Tasking
;
84 -- used for Send_Trace_Info
86 package body System
.Tasking
.Rendezvous
is
88 package STPO
renames System
.Task_Primitives
.Operations
;
89 package POO
renames Protected_Objects
.Operations
;
90 package POE
renames Protected_Objects
.Entries
;
93 use Task_Primitives
.Operations
;
95 use System
.Traces
.Tasking
;
97 type Select_Treatment
is (
98 Accept_Alternative_Selected
, -- alternative with non-null body
99 Accept_Alternative_Completed
, -- alternative with null body
102 Accept_Alternative_Open
,
103 No_Alternative_Open
);
105 Default_Treatment
: constant array (Select_Modes
) of Select_Treatment
:=
106 (Simple_Mode
=> No_Alternative_Open
,
107 Else_Mode
=> Else_Selected
,
108 Terminate_Mode
=> Terminate_Selected
,
109 Delay_Mode
=> No_Alternative_Open
);
111 New_State
: constant array (Boolean, Entry_Call_State
)
112 of Entry_Call_State
:=
114 (Never_Abortable
=> Never_Abortable
,
115 Not_Yet_Abortable
=> Now_Abortable
,
116 Was_Abortable
=> Now_Abortable
,
117 Now_Abortable
=> Now_Abortable
,
119 Cancelled
=> Cancelled
),
121 (Never_Abortable
=> Never_Abortable
,
122 Not_Yet_Abortable
=> Not_Yet_Abortable
,
123 Was_Abortable
=> Was_Abortable
,
124 Now_Abortable
=> Now_Abortable
,
126 Cancelled
=> Cancelled
)
129 -----------------------
130 -- Local Subprograms --
131 -----------------------
133 procedure Local_Defer_Abort
(Self_Id
: Task_ID
) renames
134 System
.Tasking
.Initialization
.Defer_Abort_Nestable
;
136 procedure Local_Undefer_Abort
(Self_Id
: Task_ID
) renames
137 System
.Tasking
.Initialization
.Undefer_Abort_Nestable
;
139 -- Florist defers abort around critical sections that
140 -- make entry calls to the Interrupt_Manager task, which
141 -- violates the general rule about top-level runtime system
142 -- calls from abort-deferred regions. It is not that this is
143 -- unsafe, but when it occurs in "normal" programs it usually
144 -- means either the user is trying to do a potentially blocking
145 -- operation from within a protected object, or there is a
146 -- runtime system/compiler error that has failed to undefer
147 -- an earlier abort deferral. Thus, for debugging it may be
148 -- wise to modify the above renamings to the non-nestable forms.
150 procedure Boost_Priority
(Call
: Entry_Call_Link
; Acceptor
: Task_ID
);
151 pragma Inline
(Boost_Priority
);
152 -- Call this only with abort deferred and holding lock of Acceptor.
154 procedure Call_Synchronous
156 E
: Task_Entry_Index
;
157 Uninterpreted_Data
: System
.Address
;
159 Rendezvous_Successful
: out Boolean);
160 pragma Inline
(Call_Synchronous
);
161 -- This call is used to make a simple or conditional entry call.
162 -- Called from Call_Simple and Task_Entry_Call.
164 procedure Setup_For_Rendezvous_With_Body
165 (Entry_Call
: Entry_Call_Link
;
167 pragma Inline
(Setup_For_Rendezvous_With_Body
);
168 -- Call this only with abort deferred and holding lock of Acceptor.
169 -- When a rendezvous selected (ready for rendezvous) we need to save
170 -- previous caller and adjust the priority. Also we need to make
171 -- this call not Abortable (Cancellable) since the rendezvous has
172 -- already been started.
174 procedure Wait_For_Call
(Self_Id
: Task_ID
);
175 pragma Inline
(Wait_For_Call
);
176 -- Call this only with abort deferred and holding lock of Self_Id.
177 -- An accepting task goes into Sleep by calling this routine
178 -- waiting for a call from the caller or waiting for an abort.
179 -- Make sure Self_Id is locked before calling this routine.
185 procedure Accept_Call
186 (E
: Task_Entry_Index
;
187 Uninterpreted_Data
: out System
.Address
)
189 Self_Id
: constant Task_ID
:= STPO
.Self
;
190 Caller
: Task_ID
:= null;
191 Open_Accepts
: aliased Accept_List
(1 .. 1);
192 Entry_Call
: Entry_Call_Link
;
195 Initialization
.Defer_Abort
(Self_Id
);
201 STPO
.Write_Lock
(Self_Id
);
203 if not Self_Id
.Callable
then
204 pragma Assert
(Self_Id
.Pending_ATC_Level
= 0);
206 pragma Assert
(Self_Id
.Pending_Action
);
208 STPO
.Unlock
(Self_Id
);
214 Initialization
.Undefer_Abort
(Self_Id
);
216 -- Should never get here ???
218 pragma Assert
(False);
219 raise Standard
'Abort_Signal;
222 Queuing
.Dequeue_Head
(Self_Id
.Entry_Queues
(E
), Entry_Call
);
224 if Entry_Call
/= null then
225 Caller
:= Entry_Call
.Self
;
226 Setup_For_Rendezvous_With_Body
(Entry_Call
, Self_Id
);
227 Uninterpreted_Data
:= Entry_Call
.Uninterpreted_Data
;
232 Open_Accepts
(1).Null_Body
:= False;
233 Open_Accepts
(1).S
:= E
;
234 Self_Id
.Open_Accepts
:= Open_Accepts
'Unrestricted_Access;
236 -- Wait for normal call
238 if Parameters
.Runtime_Traces
then
239 Send_Trace_Info
(W_Accept
, Self_Id
, Integer (Open_Accepts
'Length));
243 (Debug
.Trace
(Self_Id
, "Accept_Call: wait", 'R'));
244 Wait_For_Call
(Self_Id
);
246 pragma Assert
(Self_Id
.Open_Accepts
= null);
248 if Self_Id
.Common
.Call
/= null then
249 Caller
:= Self_Id
.Common
.Call
.Self
;
250 Uninterpreted_Data
:=
251 Caller
.Entry_Calls
(Caller
.ATC_Nesting_Level
).Uninterpreted_Data
;
253 -- Case of an aborted task.
255 Uninterpreted_Data
:= System
.Null_Address
;
259 -- Self_Id.Common.Call should already be updated by the Caller
260 -- On return, we will start the rendezvous.
262 STPO
.Unlock
(Self_Id
);
268 Initialization
.Undefer_Abort
(Self_Id
);
270 if Parameters
.Runtime_Traces
then
271 Send_Trace_Info
(M_Accept_Complete
, Caller
, Entry_Index
(E
));
279 procedure Accept_Trivial
(E
: Task_Entry_Index
) is
280 Self_Id
: constant Task_ID
:= STPO
.Self
;
281 Caller
: Task_ID
:= null;
282 Open_Accepts
: aliased Accept_List
(1 .. 1);
283 Entry_Call
: Entry_Call_Link
;
286 Initialization
.Defer_Abort_Nestable
(Self_Id
);
292 STPO
.Write_Lock
(Self_Id
);
294 if not Self_Id
.Callable
then
295 pragma Assert
(Self_Id
.Pending_ATC_Level
= 0);
297 pragma Assert
(Self_Id
.Pending_Action
);
299 STPO
.Unlock
(Self_Id
);
305 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
307 -- Should never get here ???
309 pragma Assert
(False);
310 raise Standard
'Abort_Signal;
313 Queuing
.Dequeue_Head
(Self_Id
.Entry_Queues
(E
), Entry_Call
);
315 if Entry_Call
= null then
316 -- Need to wait for entry call
318 Open_Accepts
(1).Null_Body
:= True;
319 Open_Accepts
(1).S
:= E
;
320 Self_Id
.Open_Accepts
:= Open_Accepts
'Unrestricted_Access;
322 if Parameters
.Runtime_Traces
then
323 Send_Trace_Info
(W_Accept
, Self_Id
, Integer (Open_Accepts
'Length));
327 (Debug
.Trace
(Self_Id
, "Accept_Trivial: wait", 'R'));
329 Wait_For_Call
(Self_Id
);
331 pragma Assert
(Self_Id
.Open_Accepts
= null);
333 -- No need to do anything special here for pending abort.
334 -- Abort_Signal will be raised by Undefer on exit.
336 STPO
.Unlock
(Self_Id
);
338 else -- found caller already waiting
339 pragma Assert
(Entry_Call
.State
< Done
);
341 STPO
.Unlock
(Self_Id
);
342 Caller
:= Entry_Call
.Self
;
344 STPO
.Write_Lock
(Caller
);
345 Initialization
.Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
346 STPO
.Unlock
(Caller
);
349 if Parameters
.Runtime_Traces
then
350 Send_Trace_Info
(M_Accept_Complete
);
352 -- Fake one, since there is (???) no way
353 -- to know that the rendezvous is over
355 Send_Trace_Info
(M_RDV_Complete
);
362 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
369 procedure Boost_Priority
(Call
: Entry_Call_Link
; Acceptor
: Task_ID
) is
370 Caller
: constant Task_ID
:= Call
.Self
;
371 Caller_Prio
: constant System
.Any_Priority
:= Get_Priority
(Caller
);
372 Acceptor_Prio
: constant System
.Any_Priority
:= Get_Priority
(Acceptor
);
375 if Caller_Prio
> Acceptor_Prio
then
376 Call
.Acceptor_Prev_Priority
:= Acceptor_Prio
;
377 Set_Priority
(Acceptor
, Caller_Prio
);
380 Call
.Acceptor_Prev_Priority
:= Priority_Not_Boosted
;
388 procedure Call_Simple
390 E
: Task_Entry_Index
;
391 Uninterpreted_Data
: System
.Address
)
393 Rendezvous_Successful
: Boolean;
396 (Acceptor
, E
, Uninterpreted_Data
, Simple_Call
, Rendezvous_Successful
);
399 ----------------------
400 -- Call_Synchronous --
401 ----------------------
403 procedure Call_Synchronous
405 E
: Task_Entry_Index
;
406 Uninterpreted_Data
: System
.Address
;
408 Rendezvous_Successful
: out Boolean)
410 Self_Id
: constant Task_ID
:= STPO
.Self
;
412 Entry_Call
: Entry_Call_Link
;
415 pragma Assert
(Mode
/= Asynchronous_Call
);
417 Local_Defer_Abort
(Self_Id
);
418 Self_Id
.ATC_Nesting_Level
:= Self_Id
.ATC_Nesting_Level
+ 1;
420 (Debug
.Trace
(Self_Id
, "CS: entered ATC level: " &
421 ATC_Level
'Image (Self_Id
.ATC_Nesting_Level
), 'A'));
422 Level
:= Self_Id
.ATC_Nesting_Level
;
423 Entry_Call
:= Self_Id
.Entry_Calls
(Level
)'Access;
424 Entry_Call
.Next
:= null;
425 Entry_Call
.Mode
:= Mode
;
426 Entry_Call
.Cancellation_Attempted
:= False;
428 if Parameters
.Runtime_Traces
then
429 Send_Trace_Info
(W_Call
, Acceptor
, Entry_Index
(E
));
432 -- If this is a call made inside of an abort deferred region,
433 -- the call should be never abortable.
435 if Self_Id
.Deferral_Level
> 1 then
436 Entry_Call
.State
:= Never_Abortable
;
438 Entry_Call
.State
:= Now_Abortable
;
441 Entry_Call
.E
:= Entry_Index
(E
);
442 Entry_Call
.Prio
:= Get_Priority
(Self_Id
);
443 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
444 Entry_Call
.Called_Task
:= Acceptor
;
445 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
447 -- Note: the caller will undefer abort on return (see WARNING above)
453 if not Task_Do_Or_Queue
454 (Self_Id
, Entry_Call
, With_Abort
=> True)
456 Self_Id
.ATC_Nesting_Level
:= Self_Id
.ATC_Nesting_Level
- 1;
462 if Parameters
.Runtime_Traces
then
463 Send_Trace_Info
(E_Missed
, Acceptor
);
466 Initialization
.Undefer_Abort
(Self_Id
);
468 (Debug
.Trace
(Self_Id
, "CS: exited to ATC level: " &
469 ATC_Level
'Image (Self_Id
.ATC_Nesting_Level
), 'A'));
473 STPO
.Write_Lock
(Self_Id
);
475 (Debug
.Trace
(Self_Id
, "Call_Synchronous: wait", 'R'));
476 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
478 (Debug
.Trace
(Self_Id
, "Call_Synchronous: done waiting", 'R'));
479 Rendezvous_Successful
:= Entry_Call
.State
= Done
;
480 STPO
.Unlock
(Self_Id
);
486 Local_Undefer_Abort
(Self_Id
);
487 Entry_Calls
.Check_Exception
(Self_Id
, Entry_Call
);
488 end Call_Synchronous
;
494 function Callable
(T
: Task_ID
) return Boolean is
496 Self_Id
: constant Task_ID
:= STPO
.Self
;
499 Initialization
.Defer_Abort
(Self_Id
);
506 Result
:= T
.Callable
;
513 Initialization
.Undefer_Abort
(Self_Id
);
517 ----------------------------
518 -- Cancel_Task_Entry_Call --
519 ----------------------------
521 procedure Cancel_Task_Entry_Call
(Cancelled
: out Boolean) is
523 Entry_Calls
.Try_To_Cancel_Entry_Call
(Cancelled
);
524 end Cancel_Task_Entry_Call
;
526 -------------------------
527 -- Complete_Rendezvous --
528 -------------------------
530 procedure Complete_Rendezvous
is
532 Exceptional_Complete_Rendezvous
(Ada
.Exceptions
.Null_Id
);
533 end Complete_Rendezvous
;
535 -------------------------------------
536 -- Exceptional_Complete_Rendezvous --
537 -------------------------------------
539 procedure Exceptional_Complete_Rendezvous
540 (Ex
: Ada
.Exceptions
.Exception_Id
)
542 Self_Id
: constant Task_ID
:= STPO
.Self
;
543 Entry_Call
: Entry_Call_Link
:= Self_Id
.Common
.Call
;
545 Called_PO
: STPE
.Protection_Entries_Access
;
547 Exception_To_Raise
: Ada
.Exceptions
.Exception_Id
:= Ex
;
548 Ceiling_Violation
: Boolean;
550 use type Ada
.Exceptions
.Exception_Id
;
551 procedure Internal_Reraise
;
552 pragma Import
(C
, Internal_Reraise
, "__gnat_reraise");
554 procedure Transfer_Occurrence
555 (Target
: Ada
.Exceptions
.Exception_Occurrence_Access
;
556 Source
: Ada
.Exceptions
.Exception_Occurrence
);
557 pragma Import
(C
, Transfer_Occurrence
, "__gnat_transfer_occurrence");
559 use type STPE
.Protection_Entries_Access
;
562 -- Consider phasing out Complete_Rendezvous in favor
563 -- of direct call to this with Ada.Exceptions.Null_ID.
564 -- See code expansion examples for Accept_Call and Selective_Wait.
565 -- Also consider putting an explicit re-raise after this call, in
566 -- the generated code. That way we could eliminate the
567 -- code here that reraises the exception.
569 -- The deferral level is critical here,
570 -- since we want to raise an exception or allow abort to take
571 -- place, if there is an exception or abort pending.
574 (Debug
.Trace
(Self_Id
, "Exceptional_Complete_Rendezvous", 'R'));
576 if Ex
= Ada
.Exceptions
.Null_Id
then
577 -- The call came from normal end-of-rendezvous,
578 -- so abort is not yet deferred.
580 if Parameters
.Runtime_Traces
then
581 Send_Trace_Info
(M_RDV_Complete
, Entry_Call
.Self
);
584 Initialization
.Defer_Abort_Nestable
(Self_Id
);
587 -- We need to clean up any accepts which Self may have
588 -- been serving when it was aborted.
590 if Ex
= Standard
'Abort_Signal'Identity then
595 while Entry_Call /= null loop
596 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
598 -- All forms of accept make sure that the acceptor is not
599 -- completed, before accepting further calls, so that we
600 -- can be sure that no further calls are made after the
601 -- current calls are purged.
603 Caller := Entry_Call.Self;
605 -- Take write lock. This follows the lock precedence rule that
606 -- Caller may be locked while holding lock of Acceptor.
607 -- Complete the call abnormally, with exception.
609 STPO.Write_Lock (Caller);
610 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
611 STPO.Unlock (Caller);
612 Entry_Call := Entry_Call.Acceptor_Prev_Call;
620 Caller := Entry_Call.Self;
622 if Entry_Call.Needs_Requeue then
623 -- We dare not lock Self_Id at the same time as Caller,
624 -- for fear of deadlock.
626 Entry_Call.Needs_Requeue := False;
627 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
629 if Entry_Call.Called_Task /= null then
630 -- Requeue to another task entry
636 if not Task_Do_Or_Queue
637 (Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort)
643 Initialization.Undefer_Abort (Self_Id);
652 -- Requeue to a protected entry
654 Called_PO := POE.To_Protection (Entry_Call.Called_PO);
655 STPE.Lock_Entries (Called_PO, Ceiling_Violation);
657 if Ceiling_Violation then
658 pragma Assert (Ex = Ada.Exceptions.Null_Id);
660 Exception_To_Raise := Program_Error'Identity;
661 Entry_Call.Exception_To_Raise := Exception_To_Raise;
667 STPO.Write_Lock (Caller);
668 Initialization.Wakeup_Entry_Caller
669 (Self_Id, Entry_Call, Done);
670 STPO.Unlock (Caller);
678 (Self_Id, Called_PO, Entry_Call,
679 Entry_Call.Requeue_With_Abort);
680 POO.PO_Service_Entries (Self_Id, Called_PO);
681 STPE.Unlock_Entries (Called_PO);
685 Entry_Calls.Reset_Priority
686 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
689 -- The call does not need to be requeued.
691 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
692 Entry_Call.Exception_To_Raise := Ex;
698 STPO.Write_Lock (Caller);
700 -- Done with Caller locked to make sure that Wakeup is not lost.
702 if Ex /= Ada.Exceptions.Null_Id then
704 (Caller.Common.Compiler_Data.Current_Excep'Access,
705 Self_Id.Common.Compiler_Data.Current_Excep);
708 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
709 STPO.Unlock (Caller);
715 Entry_Calls.Reset_Priority
716 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
720 Initialization.Undefer_Abort (Self_Id);
722 if Exception_To_Raise /= Ada.Exceptions.Null_Id then
726 -- ??? Do we need to give precedence to Program_Error that might be
727 -- raised due to failure of finalization, over Tasking_Error from
728 -- failure of requeue?
729 end Exceptional_Complete_Rendezvous;
731 -------------------------------------
732 -- Requeue_Protected_To_Task_Entry --
733 -------------------------------------
735 procedure Requeue_Protected_To_Task_Entry
736 (Object : STPE.Protection_Entries_Access;
738 E : Task_Entry_Index;
739 With_Abort : Boolean)
741 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
743 pragma Assert (STPO.Self.Deferral_Level > 0);
745 Entry_Call.E := Entry_Index (E);
746 Entry_Call.Called_Task := Acceptor;
747 Entry_Call.Called_PO := Null_Address;
748 Entry_Call.Requeue_With_Abort := With_Abort;
749 Object.Call_In_Progress := null;
750 end Requeue_Protected_To_Task_Entry;
752 ------------------------
753 -- Requeue_Task_Entry --
754 ------------------------
756 procedure Requeue_Task_Entry
758 E : Task_Entry_Index;
759 With_Abort : Boolean)
761 Self_Id : constant Task_ID := STPO.Self;
762 Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
765 Initialization.Defer_Abort (Self_Id);
766 Entry_Call.Needs_Requeue := True;
767 Entry_Call.Requeue_With_Abort := With_Abort;
768 Entry_Call.E := Entry_Index (E);
769 Entry_Call.Called_Task := Acceptor;
770 Initialization.Undefer_Abort (Self_Id);
771 end Requeue_Task_Entry;
777 procedure Selective_Wait
778 (Open_Accepts : Accept_List_Access;
779 Select_Mode : Select_Modes;
780 Uninterpreted_Data : out System.Address;
781 Index : out Select_Index)
783 Self_Id : constant Task_ID := STPO.Self;
784 Entry_Call : Entry_Call_Link;
785 Treatment : Select_Treatment;
787 Selection : Select_Index;
788 Open_Alternative : Boolean;
791 Initialization.Defer_Abort (Self_Id);
797 STPO.Write_Lock (Self_Id);
799 if not Self_Id.Callable then
800 pragma Assert (Self_Id.Pending_ATC_Level = 0);
802 pragma Assert (Self_Id.Pending_Action);
804 STPO.Unlock (Self_Id);
810 -- ??? In some cases abort is deferred more than once. Need to
811 -- figure out why this happens.
813 Self_Id.Deferral_Level := 1;
815 Initialization.Undefer_Abort (Self_Id);
817 -- Should never get here ???
819 pragma Assert (False);
820 raise Standard'Abort_Signal;
823 pragma Assert (Open_Accepts /= null);
825 Uninterpreted_Data := Null_Address;
827 Queuing.Select_Task_Entry_Call
828 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
830 -- Determine the kind and disposition of the select.
832 Treatment := Default_Treatment (Select_Mode);
833 Self_Id.Chosen_Index := No_Rendezvous;
835 if Open_Alternative then
836 if Entry_Call /= null then
837 if Open_Accepts (Selection).Null_Body then
838 Treatment := Accept_Alternative_Completed;
840 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
841 Treatment := Accept_Alternative_Selected;
844 Self_Id.Chosen_Index := Selection;
846 elsif Treatment = No_Alternative_Open then
847 Treatment := Accept_Alternative_Open;
851 -- Handle the select according to the disposition selected above.
854 when Accept_Alternative_Selected =>
855 -- Ready to rendezvous
857 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
859 -- In this case the accept body is not Null_Body. Defer abort
860 -- until it gets into the accept body.
862 pragma Assert (Self_Id.Deferral_Level = 1);
864 Initialization.Defer_Abort_Nestable (Self_Id);
865 STPO.Unlock (Self_Id);
867 when Accept_Alternative_Completed =>
868 -- Accept body is null, so rendezvous is over immediately.
870 if Parameters.Runtime_Traces then
871 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
874 STPO.Unlock (Self_Id);
875 Caller := Entry_Call.Self;
877 STPO.Write_Lock (Caller);
878 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
879 STPO.Unlock (Caller);
881 when Accept_Alternative_Open =>
884 Self_Id.Open_Accepts := Open_Accepts;
886 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R
'));
888 if Parameters.Runtime_Traces then
889 Send_Trace_Info (W_Select, Self_Id,
890 Integer (Open_Accepts'Length));
893 Wait_For_Call (Self_Id);
895 pragma Assert (Self_Id.Open_Accepts = null);
897 -- Self_Id.Common.Call should already be updated by the Caller if
898 -- not aborted. It might also be ready to do rendezvous even if
899 -- this wakes up due to an abortion.
900 -- Therefore, if the call is not empty we need to do the
901 -- rendezvous if the accept body is not Null_Body.
903 -- Aren't the first two conditions below redundant???
905 if Self_Id.Chosen_Index /= No_Rendezvous
906 and then Self_Id.Common.Call /= null
907 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
909 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
911 pragma Assert (Self_Id.Deferral_Level = 1);
913 Initialization.Defer_Abort_Nestable (Self_Id);
915 -- Leave abort deferred until the accept body
918 STPO.Unlock (Self_Id);
920 when Else_Selected =>
921 pragma Assert (Self_Id.Open_Accepts = null);
923 if Parameters.Runtime_Traces then
924 Send_Trace_Info (M_Select_Else);
927 STPO.Unlock (Self_Id);
929 when Terminate_Selected =>
930 -- Terminate alternative is open
932 Self_Id.Open_Accepts := Open_Accepts;
933 Self_Id.Common.State := Acceptor_Sleep;
935 -- Notify ancestors that this task is on a terminate alternative.
937 STPO.Unlock (Self_Id);
938 Utilities.Make_Passive (Self_Id, Task_Completed => False);
939 STPO.Write_Lock (Self_Id);
941 -- Wait for normal entry call or termination
943 Wait_For_Call (Self_Id);
945 pragma Assert (Self_Id.Open_Accepts = null);
947 if Self_Id.Terminate_Alternative then
948 -- An entry call should have reset this to False,
949 -- so we must be aborted.
950 -- We cannot be in an async. select, since that
951 -- is not legal, so the abort must be of the entire
952 -- task. Therefore, we do not need to cancel the
953 -- terminate alternative. The cleanup will be done
954 -- in Complete_Master.
956 pragma Assert (Self_Id.Pending_ATC_Level = 0);
957 pragma Assert (Self_Id.Awake_Count = 0);
959 -- Trust that it is OK to fall through.
963 -- Self_Id.Common.Call and Self_Id.Chosen_Index
964 -- should already be updated by the Caller.
966 if Self_Id.Chosen_Index /= No_Rendezvous
967 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
969 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
971 pragma Assert (Self_Id.Deferral_Level = 1);
973 -- We need an extra defer here, to keep abort
974 -- deferred until we get into the accept body
976 Initialization.Defer_Abort_Nestable (Self_Id);
980 STPO.Unlock (Self_Id);
982 when No_Alternative_Open =>
983 -- In this case, Index will be No_Rendezvous on return, which
984 -- should cause a Program_Error if it is not a Delay_Mode.
986 -- If delay alternative exists (Delay_Mode) we should suspend
987 -- until the delay expires.
989 Self_Id.Open_Accepts := null;
991 if Select_Mode = Delay_Mode then
992 Self_Id.Common.State := Delay_Sleep;
995 Initialization.Poll_Base_Priority_Change (Self_Id);
997 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
998 Sleep (Self_Id, Delay_Sleep);
1001 Self_Id.Common.State := Runnable;
1002 STPO.Unlock (Self_Id);
1005 STPO.Unlock (Self_Id);
1011 Initialization.Undefer_Abort (Self_Id);
1012 Ada.Exceptions.Raise_Exception
1013 (Program_Error'Identity, "Entry call not a delay mode");
1021 -- Caller has been chosen.
1022 -- Self_Id.Common.Call should already be updated by the Caller.
1023 -- Self_Id.Chosen_Index should either be updated by the Caller
1024 -- or by Test_Selective_Wait.
1025 -- On return, we sill start rendezvous unless the accept body is
1026 -- null. In the latter case, we will have already completed the RV.
1028 Index := Self_Id.Chosen_Index;
1029 Initialization.Undefer_Abort_Nestable (Self_Id);
1032 ------------------------------------
1033 -- Setup_For_Rendezvous_With_Body --
1034 ------------------------------------
1036 procedure Setup_For_Rendezvous_With_Body
1037 (Entry_Call : Entry_Call_Link;
1038 Acceptor : Task_ID) is
1040 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1041 Acceptor.Common.Call := Entry_Call;
1043 if Entry_Call.State = Now_Abortable then
1044 Entry_Call.State := Was_Abortable;
1047 Boost_Priority (Entry_Call, Acceptor);
1048 end Setup_For_Rendezvous_With_Body;
1054 function Task_Count (E : Task_Entry_Index) return Natural is
1055 Self_Id : constant Task_ID := STPO.Self;
1056 Return_Count : Natural;
1059 Initialization.Defer_Abort (Self_Id);
1065 STPO.Write_Lock (Self_Id);
1066 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1067 STPO.Unlock (Self_Id);
1073 Initialization.Undefer_Abort (Self_Id);
1074 return Return_Count;
1077 ----------------------
1078 -- Task_Do_Or_Queue --
1079 ----------------------
1081 function Task_Do_Or_Queue
1083 Entry_Call : Entry_Call_Link;
1084 With_Abort : Boolean) return Boolean
1086 E : constant Task_Entry_Index :=
1087 Task_Entry_Index (Entry_Call.E);
1088 Old_State : constant Entry_Call_State := Entry_Call.State;
1089 Acceptor : constant Task_ID := Entry_Call.Called_Task;
1090 Parent : constant Task_ID := Acceptor.Common.Parent;
1091 Parent_Locked : Boolean := False;
1092 Null_Body : Boolean;
1095 -- Find out whether Entry_Call can be accepted immediately.
1096 -- If the Acceptor is not callable, return False.
1097 -- If the rendezvous can start, initiate it.
1098 -- If the accept-body is trivial, also complete the rendezvous.
1099 -- If the acceptor is not ready, enqueue the call.
1101 -- This should have a special case for Accept_Call and Accept_Trivial,
1102 -- so that we don't have the loop setup overhead, below.
1104 -- The call state Done is used here and elsewhere to include both the
1105 -- case of normal successful completion, and the case of an exception
1106 -- being raised. The difference is that if an exception is raised no one
1107 -- will pay attention to the fact that State = Done. Instead the
1108 -- exception will be raised in Undefer_Abort, and control will skip past
1109 -- the place where we normally would resume from an entry call.
1111 pragma Assert (not Queuing.Onqueue (Entry_Call));
1113 -- We rely that the call is off-queue for protection, that the caller
1114 -- will not exit the Entry_Caller_Sleep, and so will not reuse the call
1115 -- record for another call.
1116 -- We rely on the Caller's lock for call State mod's.
1118 -- We can't lock Acceptor.Parent while holding Acceptor,
1119 -- so lock it in advance if we expect to need to lock it.
1121 if Acceptor.Terminate_Alternative then
1122 STPO.Write_Lock (Parent);
1123 Parent_Locked := True;
1126 STPO.Write_Lock (Acceptor);
1128 -- If the acceptor is not callable, abort the call and return False.
1130 if not Acceptor.Callable then
1131 STPO.Unlock (Acceptor);
1133 if Parent_Locked then
1134 STPO.Unlock (Parent);
1137 pragma Assert (Entry_Call.State < Done);
1139 -- In case we are not the caller, set up the caller
1140 -- to raise Tasking_Error when it wakes up.
1142 STPO.Write_Lock (Entry_Call.Self);
1143 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1144 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1145 STPO.Unlock (Entry_Call.Self);
1150 -- Try to serve the call immediately.
1152 if Acceptor.Open_Accepts /= null then
1153 for J in Acceptor.Open_Accepts'Range loop
1154 if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1156 -- Commit acceptor to rendezvous with us.
1158 Acceptor.Chosen_Index := J;
1159 Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1160 Acceptor.Open_Accepts := null;
1162 -- Prevent abort while call is being served.
1164 if Entry_Call.State = Now_Abortable then
1165 Entry_Call.State := Was_Abortable;
1168 if Acceptor.Terminate_Alternative then
1169 -- Cancel terminate alternative.
1170 -- See matching code in Selective_Wait and
1171 -- Vulnerable_Complete_Master.
1173 Acceptor.Terminate_Alternative := False;
1174 Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1176 if Acceptor.Awake_Count = 1 then
1178 -- Notify parent that acceptor is awake.
1180 pragma Assert (Parent.Awake_Count > 0);
1182 Parent.Awake_Count := Parent.Awake_Count + 1;
1184 if Parent.Common.State = Master_Completion_Sleep
1185 and then Acceptor.Master_of_Task = Parent.Master_Within
1187 Parent.Common.Wait_Count :=
1188 Parent.Common.Wait_Count + 1;
1194 -- Rendezvous is over immediately.
1196 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1197 STPO.Unlock (Acceptor);
1199 if Parent_Locked then
1200 STPO.Unlock (Parent);
1203 STPO.Write_Lock (Entry_Call.Self);
1204 Initialization.Wakeup_Entry_Caller
1205 (Self_ID, Entry_Call, Done);
1206 STPO.Unlock (Entry_Call.Self);
1209 Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1211 -- For terminate_alternative, acceptor may not be
1212 -- asleep yet, so we skip the wakeup
1214 if Acceptor.Common.State /= Runnable then
1215 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1218 STPO.Unlock (Acceptor);
1220 if Parent_Locked then
1221 STPO.Unlock (Parent);
1229 -- The acceptor is accepting, but not this entry.
1232 -- If the acceptor was ready to accept this call,
1233 -- we would not have gotten this far, so now we should
1234 -- (re)enqueue the call, if the mode permits that.
1236 if Entry_Call.Mode /= Conditional_Call
1237 or else not With_Abort
1239 -- Timed_Call, Simple_Call, or Asynchronous_Call
1241 Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1243 -- Update abortability of call
1245 pragma Assert (Old_State < Done);
1247 Entry_Call.State := New_State (With_Abort, Entry_Call.State);
1249 STPO.Unlock (Acceptor);
1251 if Parent_Locked then
1252 STPO.Unlock (Parent);
1255 if Old_State /= Entry_Call.State
1256 and then Entry_Call.State = Now_Abortable
1257 and then Entry_Call.Mode > Simple_Call
1258 and then Entry_Call.Self /= Self_ID
1260 -- Asynchronous_Call or Conditional_Call
1263 -- Because of ATCB lock ordering rule
1265 STPO.Write_Lock (Entry_Call.Self);
1267 if Entry_Call.Self.Common.State = Async_Select_Sleep then
1269 -- Caller may not yet have reached wait-point
1271 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1274 STPO.Unlock (Entry_Call.Self);
1278 -- Conditional_Call and With_Abort
1280 STPO.Unlock (Acceptor);
1282 if Parent_Locked then
1283 STPO.Unlock (Parent);
1286 STPO.Write_Lock (Entry_Call.Self);
1288 pragma Assert (Entry_Call.State >= Was_Abortable);
1290 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1291 STPO.Unlock (Entry_Call.Self);
1295 end Task_Do_Or_Queue;
1297 ---------------------
1298 -- Task_Entry_Call --
1299 ---------------------
1301 procedure Task_Entry_Call
1302 (Acceptor : Task_ID;
1303 E : Task_Entry_Index;
1304 Uninterpreted_Data : System.Address;
1306 Rendezvous_Successful : out Boolean)
1308 Self_Id : constant Task_ID := STPO.Self;
1309 Entry_Call : Entry_Call_Link;
1312 if Parameters.Runtime_Traces then
1313 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1316 if Mode = Simple_Call or else Mode = Conditional_Call then
1318 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1321 -- This is an asynchronous call
1323 -- Abortion must already be deferred by the compiler-generated
1324 -- code. Without this, an abortion that occurs between the time
1325 -- that this call is made and the time that the abortable part's
1326 -- cleanup handler is set up might miss the cleanup handler and
1327 -- leave the call pending.
1329 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1331 (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1332 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A
'));
1333 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1334 Entry_Call.Next := null;
1335 Entry_Call.Mode := Mode;
1336 Entry_Call.Cancellation_Attempted := False;
1337 Entry_Call.State := Not_Yet_Abortable;
1338 Entry_Call.E := Entry_Index (E);
1339 Entry_Call.Prio := Get_Priority (Self_Id);
1340 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1341 Entry_Call.Called_Task := Acceptor;
1342 Entry_Call.Called_PO := Null_Address;
1343 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1349 if not Task_Do_Or_Queue
1350 (Self_Id, Entry_Call, With_Abort => True)
1352 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
1354 (Debug.Trace (Self_Id, "TEC: exited to ATC level: " &
1355 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A
'));
1361 Initialization.Undefer_Abort (Self_Id);
1363 if Parameters.Runtime_Traces then
1364 Send_Trace_Info (E_Missed, Acceptor);
1367 raise Tasking_Error;
1370 -- The following is special for async. entry calls.
1371 -- If the call was not queued abortably, we need to wait until
1372 -- it is before proceeding with the abortable part.
1374 -- Wait_Until_Abortable can be called unconditionally here,
1375 -- but it is expensive.
1377 if Entry_Call.State < Was_Abortable then
1378 Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1385 -- Note: following assignment needs to be atomic.
1387 Rendezvous_Successful := Entry_Call.State = Done;
1389 end Task_Entry_Call;
1391 -----------------------
1392 -- Task_Entry_Caller --
1393 -----------------------
1395 function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_ID is
1396 Self_Id : constant Task_ID := STPO.Self;
1397 Entry_Call : Entry_Call_Link;
1400 Entry_Call := Self_Id.Common.Call;
1402 for Depth in 1 .. D loop
1403 Entry_Call := Entry_Call.Acceptor_Prev_Call;
1404 pragma Assert (Entry_Call /= null);
1407 return Entry_Call.Self;
1408 end Task_Entry_Caller;
1410 --------------------------
1411 -- Timed_Selective_Wait --
1412 --------------------------
1414 procedure Timed_Selective_Wait
1415 (Open_Accepts : Accept_List_Access;
1416 Select_Mode : Select_Modes;
1417 Uninterpreted_Data : out System.Address;
1420 Index : out Select_Index)
1422 Self_Id : constant Task_ID := STPO.Self;
1423 Treatment : Select_Treatment;
1424 Entry_Call : Entry_Call_Link;
1426 Selection : Select_Index;
1427 Open_Alternative : Boolean;
1428 Timedout : Boolean := False;
1429 Yielded : Boolean := True;
1432 pragma Assert (Select_Mode = Delay_Mode);
1434 Initialization.Defer_Abort (Self_Id);
1436 -- If we are aborted here, the effect will be pending
1442 STPO.Write_Lock (Self_Id);
1444 if not Self_Id.Callable then
1445 pragma Assert (Self_Id.Pending_ATC_Level = 0);
1447 pragma Assert (Self_Id.Pending_Action);
1449 STPO.Unlock (Self_Id);
1455 Initialization.Undefer_Abort (Self_Id);
1457 -- Should never get here ???
1459 pragma Assert (False);
1460 raise Standard'Abort_Signal;
1463 Uninterpreted_Data := Null_Address;
1465 pragma Assert (Open_Accepts /= null);
1467 Queuing.Select_Task_Entry_Call
1468 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1470 -- Determine the kind and disposition of the select.
1472 Treatment := Default_Treatment (Select_Mode);
1473 Self_Id.Chosen_Index := No_Rendezvous;
1475 if Open_Alternative then
1476 if Entry_Call /= null then
1477 if Open_Accepts (Selection).Null_Body then
1478 Treatment := Accept_Alternative_Completed;
1481 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1482 Treatment := Accept_Alternative_Selected;
1485 Self_Id.Chosen_Index := Selection;
1487 elsif Treatment = No_Alternative_Open then
1488 Treatment := Accept_Alternative_Open;
1492 -- Handle the select according to the disposition selected above.
1495 when Accept_Alternative_Selected =>
1496 -- Ready to rendezvous
1497 -- In this case the accept body is not Null_Body. Defer abort
1498 -- until it gets into the accept body.
1500 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1501 Initialization.Defer_Abort (Self_Id);
1502 STPO.Unlock (Self_Id);
1504 when Accept_Alternative_Completed =>
1505 -- Rendezvous is over
1507 if Parameters.Runtime_Traces then
1508 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1511 STPO.Unlock (Self_Id);
1512 Caller := Entry_Call.Self;
1514 STPO.Write_Lock (Caller);
1515 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1516 STPO.Unlock (Caller);
1518 when Accept_Alternative_Open =>
1521 Self_Id.Open_Accepts := Open_Accepts;
1523 -- Wait for a normal call and a pending action until the
1524 -- Wakeup_Time is reached.
1526 -- Try to remove calls to Sleep in the loop below by letting the
1527 -- caller a chance of getting ready immediately, using Unlock &
1529 -- See similar action in Wait_For_Completion & Wait_For_Call.
1537 if Self_Id.Open_Accepts /= null then
1544 Write_Lock (Self_Id);
1547 -- Check if this task has been aborted while the lock was released
1549 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1550 Self_Id.Open_Accepts := null;
1553 Self_Id.Common.State := Acceptor_Sleep;
1556 Initialization.Poll_Base_Priority_Change (Self_Id);
1557 exit when Self_Id.Open_Accepts = null;
1560 Sleep (Self_Id, Acceptor_Sleep);
1562 if Parameters.Runtime_Traces then
1563 Send_Trace_Info (WT_Select,
1565 Integer (Open_Accepts'Length),
1569 STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1570 Acceptor_Sleep, Timedout, Yielded);
1574 Self_Id.Open_Accepts := null;
1576 if Parameters.Runtime_Traces then
1577 Send_Trace_Info (E_Timeout);
1582 Self_Id.Common.State := Runnable;
1584 -- Self_Id.Common.Call should already be updated by the Caller if
1585 -- not aborted. It might also be ready to do rendezvous even if
1586 -- this wakes up due to an abortion.
1587 -- Therefore, if the call is not empty we need to do the
1588 -- rendezvous if the accept body is not Null_Body.
1590 if Self_Id.Chosen_Index /= No_Rendezvous
1591 and then Self_Id.Common.Call /= null
1592 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1594 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1596 pragma Assert (Self_Id.Deferral_Level = 1);
1598 Initialization.Defer_Abort_Nestable (Self_Id);
1600 -- Leave abort deferred until the accept body
1603 STPO.Unlock (Self_Id);
1605 when No_Alternative_Open =>
1606 -- In this case, Index will be No_Rendezvous on return. We sleep
1607 -- for the time we need to.
1608 -- Wait for a signal or timeout. A wakeup can be made
1609 -- for several reasons:
1610 -- 1) Delay is expired
1611 -- 2) Pending_Action needs to be checked
1612 -- (Abortion, Priority change)
1613 -- 3) Spurious wakeup
1615 Self_Id.Open_Accepts := null;
1616 Self_Id.Common.State := Acceptor_Sleep;
1618 Initialization.Poll_Base_Priority_Change (Self_Id);
1620 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
1623 Self_Id.Common.State := Runnable;
1625 STPO.Unlock (Self_Id);
1628 -- Should never get here
1629 pragma Assert (False);
1641 -- Caller has been chosen
1643 -- Self_Id.Common.Call should already be updated by the Caller
1645 -- Self_Id.Chosen_Index should either be updated by the Caller
1646 -- or by Test_Selective_Wait
1648 Index := Self_Id.Chosen_Index;
1649 Initialization.Undefer_Abort_Nestable (Self_Id);
1651 -- Start rendezvous, if not already completed
1652 end Timed_Selective_Wait;
1654 ---------------------------
1655 -- Timed_Task_Entry_Call --
1656 ---------------------------
1658 procedure Timed_Task_Entry_Call
1659 (Acceptor : Task_ID;
1660 E : Task_Entry_Index;
1661 Uninterpreted_Data : System.Address;
1664 Rendezvous_Successful : out Boolean)
1666 Self_Id : constant Task_ID := STPO.Self;
1668 Entry_Call : Entry_Call_Link;
1672 Initialization.Defer_Abort (Self_Id);
1673 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1676 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1677 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A
'));
1679 if Parameters.Runtime_Traces then
1680 Send_Trace_Info (WT_Call, Acceptor,
1681 Entry_Index (E), Timeout);
1684 Level := Self_Id.ATC_Nesting_Level;
1685 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1686 Entry_Call.Next := null;
1687 Entry_Call.Mode := Timed_Call;
1688 Entry_Call.Cancellation_Attempted := False;
1690 -- If this is a call made inside of an abort deferred region,
1691 -- the call should be never abortable.
1693 if Self_Id.Deferral_Level > 1 then
1694 Entry_Call.State := Never_Abortable;
1696 Entry_Call.State := Now_Abortable;
1699 Entry_Call.E := Entry_Index (E);
1700 Entry_Call.Prio := Get_Priority (Self_Id);
1701 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1702 Entry_Call.Called_Task := Acceptor;
1703 Entry_Call.Called_PO := Null_Address;
1704 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1706 -- Note: the caller will undefer abortion on return (see WARNING above)
1712 if not Task_Do_Or_Queue
1713 (Self_Id, Entry_Call, With_Abort => True)
1715 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
1718 (Debug.Trace (Self_Id, "TTEC: exited to ATC level: " &
1719 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A
'));
1725 Initialization.Undefer_Abort (Self_Id);
1727 if Parameters.Runtime_Traces then
1728 Send_Trace_Info (E_Missed, Acceptor);
1730 raise Tasking_Error;
1733 Write_Lock (Self_Id);
1734 Entry_Calls.Wait_For_Completion_With_Timeout
1735 (Entry_Call, Timeout, Mode, Yielded);
1742 -- ??? Do we need to yield in case Yielded is False
1744 Rendezvous_Successful := Entry_Call.State = Done;
1745 Initialization.Undefer_Abort (Self_Id);
1746 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1747 end Timed_Task_Entry_Call;
1753 procedure Wait_For_Call (Self_Id : Task_ID) is
1755 -- Try to remove calls to Sleep in the loop below by letting the caller
1756 -- a chance of getting ready immediately, using Unlock & Yield.
1757 -- See similar action in Wait_For_Completion & Selective_Wait.
1765 if Self_Id.Open_Accepts /= null then
1772 Write_Lock (Self_Id);
1775 -- Check if this task has been aborted while the lock was released.
1777 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1778 Self_Id.Open_Accepts := null;
1781 Self_Id.Common.State := Acceptor_Sleep;
1784 Initialization.Poll_Base_Priority_Change (Self_Id);
1786 exit when Self_Id.Open_Accepts = null;
1788 Sleep (Self_Id, Acceptor_Sleep);
1791 Self_Id.Common.State := Runnable;
1794 end System.Tasking.Rendezvous;