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-2004, 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
71 with System
.Tasking
.Protected_Objects
.Operations
;
72 -- 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
);
109 Default_Treatment
: constant array (Select_Modes
) of Select_Treatment
:=
110 (Simple_Mode
=> No_Alternative_Open
,
111 Else_Mode
=> Else_Selected
,
112 Terminate_Mode
=> Terminate_Selected
,
113 Delay_Mode
=> No_Alternative_Open
);
115 New_State
: constant array (Boolean, Entry_Call_State
)
116 of Entry_Call_State
:=
118 (Never_Abortable
=> Never_Abortable
,
119 Not_Yet_Abortable
=> Now_Abortable
,
120 Was_Abortable
=> Now_Abortable
,
121 Now_Abortable
=> Now_Abortable
,
123 Cancelled
=> Cancelled
),
125 (Never_Abortable
=> Never_Abortable
,
126 Not_Yet_Abortable
=> Not_Yet_Abortable
,
127 Was_Abortable
=> Was_Abortable
,
128 Now_Abortable
=> Now_Abortable
,
130 Cancelled
=> Cancelled
)
133 -----------------------
134 -- Local Subprograms --
135 -----------------------
137 procedure Local_Defer_Abort
(Self_Id
: Task_Id
) renames
138 System
.Tasking
.Initialization
.Defer_Abort_Nestable
;
140 procedure Local_Undefer_Abort
(Self_Id
: Task_Id
) renames
141 System
.Tasking
.Initialization
.Undefer_Abort_Nestable
;
143 -- Florist defers abort around critical sections that
144 -- make entry calls to the Interrupt_Manager task, which
145 -- violates the general rule about top-level runtime system
146 -- calls from abort-deferred regions. It is not that this is
147 -- unsafe, but when it occurs in "normal" programs it usually
148 -- means either the user is trying to do a potentially blocking
149 -- operation from within a protected object, or there is a
150 -- runtime system/compiler error that has failed to undefer
151 -- an earlier abort deferral. Thus, for debugging it may be
152 -- wise to modify the above renamings to the non-nestable forms.
154 procedure Boost_Priority
(Call
: Entry_Call_Link
; Acceptor
: Task_Id
);
155 pragma Inline
(Boost_Priority
);
156 -- Call this only with abort deferred and holding lock of Acceptor.
158 procedure Call_Synchronous
160 E
: Task_Entry_Index
;
161 Uninterpreted_Data
: System
.Address
;
163 Rendezvous_Successful
: out Boolean);
164 pragma Inline
(Call_Synchronous
);
165 -- This call is used to make a simple or conditional entry call.
166 -- Called from Call_Simple and Task_Entry_Call.
168 procedure Setup_For_Rendezvous_With_Body
169 (Entry_Call
: Entry_Call_Link
;
171 pragma Inline
(Setup_For_Rendezvous_With_Body
);
172 -- Call this only with abort deferred and holding lock of Acceptor.
173 -- When a rendezvous selected (ready for rendezvous) we need to save
174 -- previous caller and adjust the priority. Also we need to make
175 -- this call not Abortable (Cancellable) since the rendezvous has
176 -- already been started.
178 procedure Wait_For_Call
(Self_Id
: Task_Id
);
179 pragma Inline
(Wait_For_Call
);
180 -- Call this only with abort deferred and holding lock of Self_Id.
181 -- An accepting task goes into Sleep by calling this routine
182 -- waiting for a call from the caller or waiting for an abort.
183 -- Make sure Self_Id is locked before calling this routine.
189 procedure Accept_Call
190 (E
: Task_Entry_Index
;
191 Uninterpreted_Data
: out System
.Address
)
193 Self_Id
: constant Task_Id
:= STPO
.Self
;
194 Caller
: Task_Id
:= null;
195 Open_Accepts
: aliased Accept_List
(1 .. 1);
196 Entry_Call
: Entry_Call_Link
;
199 Initialization
.Defer_Abort
(Self_Id
);
205 STPO
.Write_Lock
(Self_Id
);
207 if not Self_Id
.Callable
then
208 pragma Assert
(Self_Id
.Pending_ATC_Level
= 0);
210 pragma Assert
(Self_Id
.Pending_Action
);
212 STPO
.Unlock
(Self_Id
);
218 Initialization
.Undefer_Abort
(Self_Id
);
220 -- Should never get here ???
222 pragma Assert
(False);
223 raise Standard
'Abort_Signal;
226 Queuing
.Dequeue_Head
(Self_Id
.Entry_Queues
(E
), Entry_Call
);
228 if Entry_Call
/= null then
229 Caller
:= Entry_Call
.Self
;
230 Setup_For_Rendezvous_With_Body
(Entry_Call
, Self_Id
);
231 Uninterpreted_Data
:= Entry_Call
.Uninterpreted_Data
;
236 Open_Accepts
(1).Null_Body
:= False;
237 Open_Accepts
(1).S
:= E
;
238 Self_Id
.Open_Accepts
:= Open_Accepts
'Unrestricted_Access;
240 -- Wait for normal call
242 if Parameters
.Runtime_Traces
then
243 Send_Trace_Info
(W_Accept
, Self_Id
, Integer (Open_Accepts
'Length));
247 (Debug
.Trace
(Self_Id
, "Accept_Call: wait", 'R'));
248 Wait_For_Call
(Self_Id
);
250 pragma Assert
(Self_Id
.Open_Accepts
= null);
252 if Self_Id
.Common
.Call
/= null then
253 Caller
:= Self_Id
.Common
.Call
.Self
;
254 Uninterpreted_Data
:=
255 Caller
.Entry_Calls
(Caller
.ATC_Nesting_Level
).Uninterpreted_Data
;
257 -- Case of an aborted task.
259 Uninterpreted_Data
:= System
.Null_Address
;
263 -- Self_Id.Common.Call should already be updated by the Caller
264 -- On return, we will start the rendezvous.
266 STPO
.Unlock
(Self_Id
);
272 Initialization
.Undefer_Abort
(Self_Id
);
274 if Parameters
.Runtime_Traces
then
275 Send_Trace_Info
(M_Accept_Complete
, Caller
, Entry_Index
(E
));
283 procedure Accept_Trivial
(E
: Task_Entry_Index
) is
284 Self_Id
: constant Task_Id
:= STPO
.Self
;
285 Caller
: Task_Id
:= null;
286 Open_Accepts
: aliased Accept_List
(1 .. 1);
287 Entry_Call
: Entry_Call_Link
;
290 Initialization
.Defer_Abort_Nestable
(Self_Id
);
296 STPO
.Write_Lock
(Self_Id
);
298 if not Self_Id
.Callable
then
299 pragma Assert
(Self_Id
.Pending_ATC_Level
= 0);
301 pragma Assert
(Self_Id
.Pending_Action
);
303 STPO
.Unlock
(Self_Id
);
309 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
311 -- Should never get here ???
313 pragma Assert
(False);
314 raise Standard
'Abort_Signal;
317 Queuing
.Dequeue_Head
(Self_Id
.Entry_Queues
(E
), Entry_Call
);
319 if Entry_Call
= null then
320 -- Need to wait for entry call
322 Open_Accepts
(1).Null_Body
:= True;
323 Open_Accepts
(1).S
:= E
;
324 Self_Id
.Open_Accepts
:= Open_Accepts
'Unrestricted_Access;
326 if Parameters
.Runtime_Traces
then
327 Send_Trace_Info
(W_Accept
, Self_Id
, Integer (Open_Accepts
'Length));
331 (Debug
.Trace
(Self_Id
, "Accept_Trivial: wait", 'R'));
333 Wait_For_Call
(Self_Id
);
335 pragma Assert
(Self_Id
.Open_Accepts
= null);
337 -- No need to do anything special here for pending abort.
338 -- Abort_Signal will be raised by Undefer on exit.
340 STPO
.Unlock
(Self_Id
);
342 else -- found caller already waiting
343 pragma Assert
(Entry_Call
.State
< Done
);
345 STPO
.Unlock
(Self_Id
);
346 Caller
:= Entry_Call
.Self
;
348 STPO
.Write_Lock
(Caller
);
349 Initialization
.Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
350 STPO
.Unlock
(Caller
);
353 if Parameters
.Runtime_Traces
then
354 Send_Trace_Info
(M_Accept_Complete
);
356 -- Fake one, since there is (???) no way
357 -- to know that the rendezvous is over
359 Send_Trace_Info
(M_RDV_Complete
);
366 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
373 procedure Boost_Priority
(Call
: Entry_Call_Link
; Acceptor
: Task_Id
) is
374 Caller
: constant Task_Id
:= Call
.Self
;
375 Caller_Prio
: constant System
.Any_Priority
:= Get_Priority
(Caller
);
376 Acceptor_Prio
: constant System
.Any_Priority
:= Get_Priority
(Acceptor
);
379 if Caller_Prio
> Acceptor_Prio
then
380 Call
.Acceptor_Prev_Priority
:= Acceptor_Prio
;
381 Set_Priority
(Acceptor
, Caller_Prio
);
384 Call
.Acceptor_Prev_Priority
:= Priority_Not_Boosted
;
392 procedure Call_Simple
394 E
: Task_Entry_Index
;
395 Uninterpreted_Data
: System
.Address
)
397 Rendezvous_Successful
: Boolean;
400 -- If pragma Detect_Blocking is active then Program_Error must be
401 -- raised if this potentially blocking operation is called from a
404 if System
.Tasking
.Detect_Blocking
405 and then STPO
.Self
.Common
.Protected_Action_Nesting
> 0
407 Ada
.Exceptions
.Raise_Exception
408 (Program_Error
'Identity, "potentially blocking operation");
412 (Acceptor
, E
, Uninterpreted_Data
, Simple_Call
, Rendezvous_Successful
);
415 ----------------------
416 -- Call_Synchronous --
417 ----------------------
419 procedure Call_Synchronous
421 E
: Task_Entry_Index
;
422 Uninterpreted_Data
: System
.Address
;
424 Rendezvous_Successful
: out Boolean)
426 Self_Id
: constant Task_Id
:= STPO
.Self
;
428 Entry_Call
: Entry_Call_Link
;
431 pragma Assert
(Mode
/= Asynchronous_Call
);
433 Local_Defer_Abort
(Self_Id
);
434 Self_Id
.ATC_Nesting_Level
:= Self_Id
.ATC_Nesting_Level
+ 1;
436 (Debug
.Trace
(Self_Id
, "CS: entered ATC level: " &
437 ATC_Level
'Image (Self_Id
.ATC_Nesting_Level
), 'A'));
438 Level
:= Self_Id
.ATC_Nesting_Level
;
439 Entry_Call
:= Self_Id
.Entry_Calls
(Level
)'Access;
440 Entry_Call
.Next
:= null;
441 Entry_Call
.Mode
:= Mode
;
442 Entry_Call
.Cancellation_Attempted
:= False;
444 if Parameters
.Runtime_Traces
then
445 Send_Trace_Info
(W_Call
, Acceptor
, Entry_Index
(E
));
448 -- If this is a call made inside of an abort deferred region,
449 -- the call should be never abortable.
451 if Self_Id
.Deferral_Level
> 1 then
452 Entry_Call
.State
:= Never_Abortable
;
454 Entry_Call
.State
:= Now_Abortable
;
457 Entry_Call
.E
:= Entry_Index
(E
);
458 Entry_Call
.Prio
:= Get_Priority
(Self_Id
);
459 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
460 Entry_Call
.Called_Task
:= Acceptor
;
461 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
463 -- Note: the caller will undefer abort on return (see WARNING above)
469 if not Task_Do_Or_Queue
470 (Self_Id
, Entry_Call
, With_Abort
=> True)
472 STPO
.Write_Lock
(Self_Id
);
473 Utilities
.Exit_One_ATC_Level
(Self_Id
);
474 STPO
.Unlock
(Self_Id
);
480 if Parameters
.Runtime_Traces
then
481 Send_Trace_Info
(E_Missed
, Acceptor
);
484 Initialization
.Undefer_Abort
(Self_Id
);
488 STPO
.Write_Lock
(Self_Id
);
490 (Debug
.Trace
(Self_Id
, "Call_Synchronous: wait", 'R'));
491 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
493 (Debug
.Trace
(Self_Id
, "Call_Synchronous: done waiting", 'R'));
494 Rendezvous_Successful
:= Entry_Call
.State
= Done
;
495 STPO
.Unlock
(Self_Id
);
501 Local_Undefer_Abort
(Self_Id
);
502 Entry_Calls
.Check_Exception
(Self_Id
, Entry_Call
);
503 end Call_Synchronous
;
509 function Callable
(T
: Task_Id
) return Boolean is
511 Self_Id
: constant Task_Id
:= STPO
.Self
;
514 Initialization
.Defer_Abort
(Self_Id
);
521 Result
:= T
.Callable
;
528 Initialization
.Undefer_Abort
(Self_Id
);
532 ----------------------------
533 -- Cancel_Task_Entry_Call --
534 ----------------------------
536 procedure Cancel_Task_Entry_Call
(Cancelled
: out Boolean) is
538 Entry_Calls
.Try_To_Cancel_Entry_Call
(Cancelled
);
539 end Cancel_Task_Entry_Call
;
541 -------------------------
542 -- Complete_Rendezvous --
543 -------------------------
545 procedure Complete_Rendezvous
is
547 Exceptional_Complete_Rendezvous
(Ada
.Exceptions
.Null_Id
);
548 end Complete_Rendezvous
;
550 -------------------------------------
551 -- Exceptional_Complete_Rendezvous --
552 -------------------------------------
554 procedure Exceptional_Complete_Rendezvous
555 (Ex
: Ada
.Exceptions
.Exception_Id
)
557 Self_Id
: constant Task_Id
:= STPO
.Self
;
558 Entry_Call
: Entry_Call_Link
:= Self_Id
.Common
.Call
;
560 Called_PO
: STPE
.Protection_Entries_Access
;
562 Exception_To_Raise
: Ada
.Exceptions
.Exception_Id
:= Ex
;
563 Ceiling_Violation
: Boolean;
565 use type Ada
.Exceptions
.Exception_Id
;
566 procedure Internal_Reraise
;
567 pragma Import
(C
, Internal_Reraise
, "__gnat_reraise");
569 procedure Transfer_Occurrence
570 (Target
: Ada
.Exceptions
.Exception_Occurrence_Access
;
571 Source
: Ada
.Exceptions
.Exception_Occurrence
);
572 pragma Import
(C
, Transfer_Occurrence
, "__gnat_transfer_occurrence");
574 use type STPE
.Protection_Entries_Access
;
577 -- Consider phasing out Complete_Rendezvous in favor
578 -- of direct call to this with Ada.Exceptions.Null_ID.
579 -- See code expansion examples for Accept_Call and Selective_Wait.
580 -- Also consider putting an explicit re-raise after this call, in
581 -- the generated code. That way we could eliminate the
582 -- code here that reraises the exception.
584 -- The deferral level is critical here,
585 -- since we want to raise an exception or allow abort to take
586 -- place, if there is an exception or abort pending.
589 (Debug
.Trace
(Self_Id
, "Exceptional_Complete_Rendezvous", 'R'));
591 if Ex
= Ada
.Exceptions
.Null_Id
then
592 -- The call came from normal end-of-rendezvous,
593 -- so abort is not yet deferred.
595 if Parameters
.Runtime_Traces
then
596 Send_Trace_Info
(M_RDV_Complete
, Entry_Call
.Self
);
599 Initialization
.Defer_Abort_Nestable
(Self_Id
);
602 -- We need to clean up any accepts which Self may have
603 -- been serving when it was aborted.
605 if Ex
= Standard
'Abort_Signal'Identity then
610 while Entry_Call /= null loop
611 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
613 -- All forms of accept make sure that the acceptor is not
614 -- completed, before accepting further calls, so that we
615 -- can be sure that no further calls are made after the
616 -- current calls are purged.
618 Caller := Entry_Call.Self;
620 -- Take write lock. This follows the lock precedence rule that
621 -- Caller may be locked while holding lock of Acceptor.
622 -- Complete the call abnormally, with exception.
624 STPO.Write_Lock (Caller);
625 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
626 STPO.Unlock (Caller);
627 Entry_Call := Entry_Call.Acceptor_Prev_Call;
635 Caller := Entry_Call.Self;
637 if Entry_Call.Needs_Requeue then
638 -- We dare not lock Self_Id at the same time as Caller,
639 -- for fear of deadlock.
641 Entry_Call.Needs_Requeue := False;
642 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
644 if Entry_Call.Called_Task /= null then
645 -- Requeue to another task entry
651 if not Task_Do_Or_Queue
652 (Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort)
658 Initialization.Undefer_Abort (Self_Id);
667 -- Requeue to a protected entry
669 Called_PO := POE.To_Protection (Entry_Call.Called_PO);
670 STPE.Lock_Entries (Called_PO, Ceiling_Violation);
672 if Ceiling_Violation then
673 pragma Assert (Ex = Ada.Exceptions.Null_Id);
675 Exception_To_Raise := Program_Error'Identity;
676 Entry_Call.Exception_To_Raise := Exception_To_Raise;
682 STPO.Write_Lock (Caller);
683 Initialization.Wakeup_Entry_Caller
684 (Self_Id, Entry_Call, Done);
685 STPO.Unlock (Caller);
693 (Self_Id, Called_PO, Entry_Call,
694 Entry_Call.Requeue_With_Abort);
695 POO.PO_Service_Entries (Self_Id, Called_PO);
699 Entry_Calls.Reset_Priority
700 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
703 -- The call does not need to be requeued.
705 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
706 Entry_Call.Exception_To_Raise := Ex;
712 STPO.Write_Lock (Caller);
714 -- Done with Caller locked to make sure that Wakeup is not lost.
716 if Ex /= Ada.Exceptions.Null_Id then
718 (Caller.Common.Compiler_Data.Current_Excep'Access,
719 Self_Id.Common.Compiler_Data.Current_Excep);
722 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
723 STPO.Unlock (Caller);
729 Entry_Calls.Reset_Priority
730 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
734 Initialization.Undefer_Abort (Self_Id);
736 if Exception_To_Raise /= Ada.Exceptions.Null_Id then
740 -- ??? Do we need to give precedence to Program_Error that might be
741 -- raised due to failure of finalization, over Tasking_Error from
742 -- failure of requeue?
743 end Exceptional_Complete_Rendezvous;
745 -------------------------------------
746 -- Requeue_Protected_To_Task_Entry --
747 -------------------------------------
749 procedure Requeue_Protected_To_Task_Entry
750 (Object : STPE.Protection_Entries_Access;
752 E : Task_Entry_Index;
753 With_Abort : Boolean)
755 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
757 pragma Assert (STPO.Self.Deferral_Level > 0);
759 Entry_Call.E := Entry_Index (E);
760 Entry_Call.Called_Task := Acceptor;
761 Entry_Call.Called_PO := Null_Address;
762 Entry_Call.Requeue_With_Abort := With_Abort;
763 Object.Call_In_Progress := null;
764 end Requeue_Protected_To_Task_Entry;
766 ------------------------
767 -- Requeue_Task_Entry --
768 ------------------------
770 procedure Requeue_Task_Entry
772 E : Task_Entry_Index;
773 With_Abort : Boolean)
775 Self_Id : constant Task_Id := STPO.Self;
776 Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
779 Initialization.Defer_Abort (Self_Id);
780 Entry_Call.Needs_Requeue := True;
781 Entry_Call.Requeue_With_Abort := With_Abort;
782 Entry_Call.E := Entry_Index (E);
783 Entry_Call.Called_Task := Acceptor;
784 Initialization.Undefer_Abort (Self_Id);
785 end Requeue_Task_Entry;
791 procedure Selective_Wait
792 (Open_Accepts : Accept_List_Access;
793 Select_Mode : Select_Modes;
794 Uninterpreted_Data : out System.Address;
795 Index : out Select_Index)
797 Self_Id : constant Task_Id := STPO.Self;
798 Entry_Call : Entry_Call_Link;
799 Treatment : Select_Treatment;
801 Selection : Select_Index;
802 Open_Alternative : Boolean;
805 Initialization.Defer_Abort (Self_Id);
811 STPO.Write_Lock (Self_Id);
813 if not Self_Id.Callable then
814 pragma Assert (Self_Id.Pending_ATC_Level = 0);
816 pragma Assert (Self_Id.Pending_Action);
818 STPO.Unlock (Self_Id);
824 -- ??? In some cases abort is deferred more than once. Need to
825 -- figure out why this happens.
827 if Self_Id.Deferral_Level > 1 then
828 Self_Id.Deferral_Level := 1;
831 Initialization.Undefer_Abort (Self_Id);
833 -- Should never get here ???
835 pragma Assert (False);
836 raise Standard'Abort_Signal;
839 pragma Assert (Open_Accepts /= null);
841 Uninterpreted_Data := Null_Address;
843 Queuing.Select_Task_Entry_Call
844 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
846 -- Determine the kind and disposition of the select.
848 Treatment := Default_Treatment (Select_Mode);
849 Self_Id.Chosen_Index := No_Rendezvous;
851 if Open_Alternative then
852 if Entry_Call /= null then
853 if Open_Accepts (Selection).Null_Body then
854 Treatment := Accept_Alternative_Completed;
856 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
857 Treatment := Accept_Alternative_Selected;
860 Self_Id.Chosen_Index := Selection;
862 elsif Treatment = No_Alternative_Open then
863 Treatment := Accept_Alternative_Open;
867 -- Handle the select according to the disposition selected above.
870 when Accept_Alternative_Selected =>
871 -- Ready to rendezvous
873 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
875 -- In this case the accept body is not Null_Body. Defer abort
876 -- until it gets into the accept body.
878 pragma Assert (Self_Id.Deferral_Level = 1);
880 Initialization.Defer_Abort_Nestable (Self_Id);
881 STPO.Unlock (Self_Id);
883 when Accept_Alternative_Completed =>
884 -- Accept body is null, so rendezvous is over immediately.
886 if Parameters.Runtime_Traces then
887 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
890 STPO.Unlock (Self_Id);
891 Caller := Entry_Call.Self;
893 STPO.Write_Lock (Caller);
894 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
895 STPO.Unlock (Caller);
897 when Accept_Alternative_Open =>
900 Self_Id.Open_Accepts := Open_Accepts;
902 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R
'));
904 if Parameters.Runtime_Traces then
905 Send_Trace_Info (W_Select, Self_Id,
906 Integer (Open_Accepts'Length));
909 Wait_For_Call (Self_Id);
911 pragma Assert (Self_Id.Open_Accepts = null);
913 -- Self_Id.Common.Call should already be updated by the Caller if
914 -- not aborted. It might also be ready to do rendezvous even if
915 -- this wakes up due to an abortion.
916 -- Therefore, if the call is not empty we need to do the
917 -- rendezvous if the accept body is not Null_Body.
919 -- Aren't the first two conditions below redundant???
921 if Self_Id.Chosen_Index /= No_Rendezvous
922 and then Self_Id.Common.Call /= null
923 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
925 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
927 pragma Assert (Self_Id.Deferral_Level = 1);
929 Initialization.Defer_Abort_Nestable (Self_Id);
931 -- Leave abort deferred until the accept body
934 STPO.Unlock (Self_Id);
936 when Else_Selected =>
937 pragma Assert (Self_Id.Open_Accepts = null);
939 if Parameters.Runtime_Traces then
940 Send_Trace_Info (M_Select_Else);
943 STPO.Unlock (Self_Id);
945 when Terminate_Selected =>
946 -- Terminate alternative is open
948 Self_Id.Open_Accepts := Open_Accepts;
949 Self_Id.Common.State := Acceptor_Sleep;
951 -- Notify ancestors that this task is on a terminate alternative.
953 STPO.Unlock (Self_Id);
954 Utilities.Make_Passive (Self_Id, Task_Completed => False);
955 STPO.Write_Lock (Self_Id);
957 -- Wait for normal entry call or termination
959 Wait_For_Call (Self_Id);
961 pragma Assert (Self_Id.Open_Accepts = null);
963 if Self_Id.Terminate_Alternative then
964 -- An entry call should have reset this to False,
965 -- so we must be aborted.
966 -- We cannot be in an async. select, since that
967 -- is not legal, so the abort must be of the entire
968 -- task. Therefore, we do not need to cancel the
969 -- terminate alternative. The cleanup will be done
970 -- in Complete_Master.
972 pragma Assert (Self_Id.Pending_ATC_Level = 0);
973 pragma Assert (Self_Id.Awake_Count = 0);
975 -- Trust that it is OK to fall through.
979 -- Self_Id.Common.Call and Self_Id.Chosen_Index
980 -- should already be updated by the Caller.
982 if Self_Id.Chosen_Index /= No_Rendezvous
983 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
985 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
987 pragma Assert (Self_Id.Deferral_Level = 1);
989 -- We need an extra defer here, to keep abort
990 -- deferred until we get into the accept body
992 Initialization.Defer_Abort_Nestable (Self_Id);
996 STPO.Unlock (Self_Id);
998 when No_Alternative_Open =>
999 -- In this case, Index will be No_Rendezvous on return, which
1000 -- should cause a Program_Error if it is not a Delay_Mode.
1002 -- If delay alternative exists (Delay_Mode) we should suspend
1003 -- until the delay expires.
1005 Self_Id.Open_Accepts := null;
1007 if Select_Mode = Delay_Mode then
1008 Self_Id.Common.State := Delay_Sleep;
1011 Initialization.Poll_Base_Priority_Change (Self_Id);
1013 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
1014 Sleep (Self_Id, Delay_Sleep);
1017 Self_Id.Common.State := Runnable;
1018 STPO.Unlock (Self_Id);
1021 STPO.Unlock (Self_Id);
1027 Initialization.Undefer_Abort (Self_Id);
1028 Ada.Exceptions.Raise_Exception
1029 (Program_Error'Identity, "Entry call not a delay mode");
1037 -- Caller has been chosen.
1038 -- Self_Id.Common.Call should already be updated by the Caller.
1039 -- Self_Id.Chosen_Index should either be updated by the Caller
1040 -- or by Test_Selective_Wait.
1041 -- On return, we sill start rendezvous unless the accept body is
1042 -- null. In the latter case, we will have already completed the RV.
1044 Index := Self_Id.Chosen_Index;
1045 Initialization.Undefer_Abort_Nestable (Self_Id);
1048 ------------------------------------
1049 -- Setup_For_Rendezvous_With_Body --
1050 ------------------------------------
1052 procedure Setup_For_Rendezvous_With_Body
1053 (Entry_Call : Entry_Call_Link;
1054 Acceptor : Task_Id) is
1056 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1057 Acceptor.Common.Call := Entry_Call;
1059 if Entry_Call.State = Now_Abortable then
1060 Entry_Call.State := Was_Abortable;
1063 Boost_Priority (Entry_Call, Acceptor);
1064 end Setup_For_Rendezvous_With_Body;
1070 function Task_Count (E : Task_Entry_Index) return Natural is
1071 Self_Id : constant Task_Id := STPO.Self;
1072 Return_Count : Natural;
1075 Initialization.Defer_Abort (Self_Id);
1081 STPO.Write_Lock (Self_Id);
1082 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1083 STPO.Unlock (Self_Id);
1089 Initialization.Undefer_Abort (Self_Id);
1090 return Return_Count;
1093 ----------------------
1094 -- Task_Do_Or_Queue --
1095 ----------------------
1097 function Task_Do_Or_Queue
1099 Entry_Call : Entry_Call_Link;
1100 With_Abort : Boolean) return Boolean
1102 E : constant Task_Entry_Index :=
1103 Task_Entry_Index (Entry_Call.E);
1104 Old_State : constant Entry_Call_State := Entry_Call.State;
1105 Acceptor : constant Task_Id := Entry_Call.Called_Task;
1106 Parent : constant Task_Id := Acceptor.Common.Parent;
1107 Parent_Locked : Boolean := False;
1108 Null_Body : Boolean;
1111 -- Find out whether Entry_Call can be accepted immediately.
1112 -- If the Acceptor is not callable, return False.
1113 -- If the rendezvous can start, initiate it.
1114 -- If the accept-body is trivial, also complete the rendezvous.
1115 -- If the acceptor is not ready, enqueue the call.
1117 -- This should have a special case for Accept_Call and Accept_Trivial,
1118 -- so that we don't have the loop setup overhead, below.
1120 -- The call state Done is used here and elsewhere to include both the
1121 -- case of normal successful completion, and the case of an exception
1122 -- being raised. The difference is that if an exception is raised no one
1123 -- will pay attention to the fact that State = Done. Instead the
1124 -- exception will be raised in Undefer_Abort, and control will skip past
1125 -- the place where we normally would resume from an entry call.
1127 pragma Assert (not Queuing.Onqueue (Entry_Call));
1129 -- We rely that the call is off-queue for protection, that the caller
1130 -- will not exit the Entry_Caller_Sleep, and so will not reuse the call
1131 -- record for another call.
1132 -- We rely on the Caller's lock for call State mod's.
1134 -- We can't lock Acceptor.Parent while holding Acceptor,
1135 -- so lock it in advance if we expect to need to lock it.
1137 if Acceptor.Terminate_Alternative then
1138 STPO.Write_Lock (Parent);
1139 Parent_Locked := True;
1142 STPO.Write_Lock (Acceptor);
1144 -- If the acceptor is not callable, abort the call and return False.
1146 if not Acceptor.Callable then
1147 STPO.Unlock (Acceptor);
1149 if Parent_Locked then
1150 STPO.Unlock (Parent);
1153 pragma Assert (Entry_Call.State < Done);
1155 -- In case we are not the caller, set up the caller
1156 -- to raise Tasking_Error when it wakes up.
1158 STPO.Write_Lock (Entry_Call.Self);
1159 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1160 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1161 STPO.Unlock (Entry_Call.Self);
1166 -- Try to serve the call immediately.
1168 if Acceptor.Open_Accepts /= null then
1169 for J in Acceptor.Open_Accepts'Range loop
1170 if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1172 -- Commit acceptor to rendezvous with us.
1174 Acceptor.Chosen_Index := J;
1175 Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1176 Acceptor.Open_Accepts := null;
1178 -- Prevent abort while call is being served.
1180 if Entry_Call.State = Now_Abortable then
1181 Entry_Call.State := Was_Abortable;
1184 if Acceptor.Terminate_Alternative then
1185 -- Cancel terminate alternative.
1186 -- See matching code in Selective_Wait and
1187 -- Vulnerable_Complete_Master.
1189 Acceptor.Terminate_Alternative := False;
1190 Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1192 if Acceptor.Awake_Count = 1 then
1194 -- Notify parent that acceptor is awake.
1196 pragma Assert (Parent.Awake_Count > 0);
1198 Parent.Awake_Count := Parent.Awake_Count + 1;
1200 if Parent.Common.State = Master_Completion_Sleep
1201 and then Acceptor.Master_of_Task = Parent.Master_Within
1203 Parent.Common.Wait_Count :=
1204 Parent.Common.Wait_Count + 1;
1210 -- Rendezvous is over immediately.
1212 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1213 STPO.Unlock (Acceptor);
1215 if Parent_Locked then
1216 STPO.Unlock (Parent);
1219 STPO.Write_Lock (Entry_Call.Self);
1220 Initialization.Wakeup_Entry_Caller
1221 (Self_ID, Entry_Call, Done);
1222 STPO.Unlock (Entry_Call.Self);
1225 Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1227 -- For terminate_alternative, acceptor may not be
1228 -- asleep yet, so we skip the wakeup
1230 if Acceptor.Common.State /= Runnable then
1231 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1234 STPO.Unlock (Acceptor);
1236 if Parent_Locked then
1237 STPO.Unlock (Parent);
1245 -- The acceptor is accepting, but not this entry.
1248 -- If the acceptor was ready to accept this call,
1249 -- we would not have gotten this far, so now we should
1250 -- (re)enqueue the call, if the mode permits that.
1252 if Entry_Call.Mode /= Conditional_Call
1253 or else not With_Abort
1255 -- Timed_Call, Simple_Call, or Asynchronous_Call
1257 Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1259 -- Update abortability of call
1261 pragma Assert (Old_State < Done);
1263 Entry_Call.State := New_State (With_Abort, Entry_Call.State);
1265 STPO.Unlock (Acceptor);
1267 if Parent_Locked then
1268 STPO.Unlock (Parent);
1271 if Old_State /= Entry_Call.State
1272 and then Entry_Call.State = Now_Abortable
1273 and then Entry_Call.Mode > Simple_Call
1274 and then Entry_Call.Self /= Self_ID
1276 -- Asynchronous_Call or Conditional_Call
1279 -- Because of ATCB lock ordering rule
1281 STPO.Write_Lock (Entry_Call.Self);
1283 if Entry_Call.Self.Common.State = Async_Select_Sleep then
1285 -- Caller may not yet have reached wait-point
1287 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1290 STPO.Unlock (Entry_Call.Self);
1294 -- Conditional_Call and With_Abort
1296 STPO.Unlock (Acceptor);
1298 if Parent_Locked then
1299 STPO.Unlock (Parent);
1302 STPO.Write_Lock (Entry_Call.Self);
1304 pragma Assert (Entry_Call.State >= Was_Abortable);
1306 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1307 STPO.Unlock (Entry_Call.Self);
1311 end Task_Do_Or_Queue;
1313 ---------------------
1314 -- Task_Entry_Call --
1315 ---------------------
1317 procedure Task_Entry_Call
1318 (Acceptor : Task_Id;
1319 E : Task_Entry_Index;
1320 Uninterpreted_Data : System.Address;
1322 Rendezvous_Successful : out Boolean)
1324 Self_Id : constant Task_Id := STPO.Self;
1325 Entry_Call : Entry_Call_Link;
1328 -- If pragma Detect_Blocking is active then Program_Error must be
1329 -- raised if this potentially blocking operation is called from a
1330 -- protected action.
1332 if System.Tasking.Detect_Blocking
1333 and then Self_Id.Common.Protected_Action_Nesting > 0
1335 Ada.Exceptions.Raise_Exception
1336 (Program_Error'Identity, "potentially blocking operation");
1339 if Parameters.Runtime_Traces then
1340 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1343 if Mode = Simple_Call or else Mode = Conditional_Call then
1345 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1348 -- This is an asynchronous call
1350 -- Abortion must already be deferred by the compiler-generated
1351 -- code. Without this, an abortion that occurs between the time
1352 -- that this call is made and the time that the abortable part's
1353 -- cleanup handler is set up might miss the cleanup handler and
1354 -- leave the call pending.
1356 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1358 (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1359 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A
'));
1360 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1361 Entry_Call.Next := null;
1362 Entry_Call.Mode := Mode;
1363 Entry_Call.Cancellation_Attempted := False;
1364 Entry_Call.State := Not_Yet_Abortable;
1365 Entry_Call.E := Entry_Index (E);
1366 Entry_Call.Prio := Get_Priority (Self_Id);
1367 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1368 Entry_Call.Called_Task := Acceptor;
1369 Entry_Call.Called_PO := Null_Address;
1370 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1376 if not Task_Do_Or_Queue
1377 (Self_Id, Entry_Call, With_Abort => True)
1379 STPO.Write_Lock (Self_Id);
1380 Utilities.Exit_One_ATC_Level (Self_Id);
1381 STPO.Unlock (Self_Id);
1387 Initialization.Undefer_Abort (Self_Id);
1389 if Parameters.Runtime_Traces then
1390 Send_Trace_Info (E_Missed, Acceptor);
1393 raise Tasking_Error;
1396 -- The following is special for async. entry calls.
1397 -- If the call was not queued abortably, we need to wait until
1398 -- it is before proceeding with the abortable part.
1400 -- Wait_Until_Abortable can be called unconditionally here,
1401 -- but it is expensive.
1403 if Entry_Call.State < Was_Abortable then
1404 Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1411 -- Note: following assignment needs to be atomic.
1413 Rendezvous_Successful := Entry_Call.State = Done;
1415 end Task_Entry_Call;
1417 -----------------------
1418 -- Task_Entry_Caller --
1419 -----------------------
1421 function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1422 Self_Id : constant Task_Id := STPO.Self;
1423 Entry_Call : Entry_Call_Link;
1426 Entry_Call := Self_Id.Common.Call;
1428 for Depth in 1 .. D loop
1429 Entry_Call := Entry_Call.Acceptor_Prev_Call;
1430 pragma Assert (Entry_Call /= null);
1433 return Entry_Call.Self;
1434 end Task_Entry_Caller;
1436 --------------------------
1437 -- Timed_Selective_Wait --
1438 --------------------------
1440 procedure Timed_Selective_Wait
1441 (Open_Accepts : Accept_List_Access;
1442 Select_Mode : Select_Modes;
1443 Uninterpreted_Data : out System.Address;
1446 Index : out Select_Index)
1448 Self_Id : constant Task_Id := STPO.Self;
1449 Treatment : Select_Treatment;
1450 Entry_Call : Entry_Call_Link;
1452 Selection : Select_Index;
1453 Open_Alternative : Boolean;
1454 Timedout : Boolean := False;
1455 Yielded : Boolean := True;
1458 pragma Assert (Select_Mode = Delay_Mode);
1460 Initialization.Defer_Abort (Self_Id);
1462 -- If we are aborted here, the effect will be pending
1468 STPO.Write_Lock (Self_Id);
1470 if not Self_Id.Callable then
1471 pragma Assert (Self_Id.Pending_ATC_Level = 0);
1473 pragma Assert (Self_Id.Pending_Action);
1475 STPO.Unlock (Self_Id);
1481 Initialization.Undefer_Abort (Self_Id);
1483 -- Should never get here ???
1485 pragma Assert (False);
1486 raise Standard'Abort_Signal;
1489 Uninterpreted_Data := Null_Address;
1491 pragma Assert (Open_Accepts /= null);
1493 Queuing.Select_Task_Entry_Call
1494 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1496 -- Determine the kind and disposition of the select.
1498 Treatment := Default_Treatment (Select_Mode);
1499 Self_Id.Chosen_Index := No_Rendezvous;
1501 if Open_Alternative then
1502 if Entry_Call /= null then
1503 if Open_Accepts (Selection).Null_Body then
1504 Treatment := Accept_Alternative_Completed;
1507 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1508 Treatment := Accept_Alternative_Selected;
1511 Self_Id.Chosen_Index := Selection;
1513 elsif Treatment = No_Alternative_Open then
1514 Treatment := Accept_Alternative_Open;
1518 -- Handle the select according to the disposition selected above.
1521 when Accept_Alternative_Selected =>
1522 -- Ready to rendezvous
1523 -- In this case the accept body is not Null_Body. Defer abort
1524 -- until it gets into the accept body.
1526 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1527 Initialization.Defer_Abort (Self_Id);
1528 STPO.Unlock (Self_Id);
1530 when Accept_Alternative_Completed =>
1531 -- Rendezvous is over
1533 if Parameters.Runtime_Traces then
1534 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1537 STPO.Unlock (Self_Id);
1538 Caller := Entry_Call.Self;
1540 STPO.Write_Lock (Caller);
1541 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1542 STPO.Unlock (Caller);
1544 when Accept_Alternative_Open =>
1547 Self_Id.Open_Accepts := Open_Accepts;
1549 -- Wait for a normal call and a pending action until the
1550 -- Wakeup_Time is reached.
1552 -- Try to remove calls to Sleep in the loop below by letting the
1553 -- caller a chance of getting ready immediately, using Unlock &
1555 -- See similar action in Wait_For_Completion & Wait_For_Call.
1563 if Self_Id.Open_Accepts /= null then
1570 Write_Lock (Self_Id);
1573 -- Check if this task has been aborted while the lock was released
1575 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1576 Self_Id.Open_Accepts := null;
1579 Self_Id.Common.State := Acceptor_Sleep;
1582 Initialization.Poll_Base_Priority_Change (Self_Id);
1583 exit when Self_Id.Open_Accepts = null;
1586 Sleep (Self_Id, Acceptor_Sleep);
1588 if Parameters.Runtime_Traces then
1589 Send_Trace_Info (WT_Select,
1591 Integer (Open_Accepts'Length),
1595 STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1596 Acceptor_Sleep, Timedout, Yielded);
1600 Self_Id.Open_Accepts := null;
1602 if Parameters.Runtime_Traces then
1603 Send_Trace_Info (E_Timeout);
1608 Self_Id.Common.State := Runnable;
1610 -- Self_Id.Common.Call should already be updated by the Caller if
1611 -- not aborted. It might also be ready to do rendezvous even if
1612 -- this wakes up due to an abortion.
1613 -- Therefore, if the call is not empty we need to do the
1614 -- rendezvous if the accept body is not Null_Body.
1616 if Self_Id.Chosen_Index /= No_Rendezvous
1617 and then Self_Id.Common.Call /= null
1618 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1620 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1622 pragma Assert (Self_Id.Deferral_Level = 1);
1624 Initialization.Defer_Abort_Nestable (Self_Id);
1626 -- Leave abort deferred until the accept body
1629 STPO.Unlock (Self_Id);
1631 when No_Alternative_Open =>
1632 -- In this case, Index will be No_Rendezvous on return. We sleep
1633 -- for the time we need to.
1634 -- Wait for a signal or timeout. A wakeup can be made
1635 -- for several reasons:
1636 -- 1) Delay is expired
1637 -- 2) Pending_Action needs to be checked
1638 -- (Abortion, Priority change)
1639 -- 3) Spurious wakeup
1641 Self_Id.Open_Accepts := null;
1642 Self_Id.Common.State := Acceptor_Sleep;
1644 Initialization.Poll_Base_Priority_Change (Self_Id);
1646 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
1649 Self_Id.Common.State := Runnable;
1651 STPO.Unlock (Self_Id);
1654 -- Should never get here
1655 pragma Assert (False);
1667 -- Caller has been chosen
1669 -- Self_Id.Common.Call should already be updated by the Caller
1671 -- Self_Id.Chosen_Index should either be updated by the Caller
1672 -- or by Test_Selective_Wait
1674 Index := Self_Id.Chosen_Index;
1675 Initialization.Undefer_Abort_Nestable (Self_Id);
1677 -- Start rendezvous, if not already completed
1678 end Timed_Selective_Wait;
1680 ---------------------------
1681 -- Timed_Task_Entry_Call --
1682 ---------------------------
1684 procedure Timed_Task_Entry_Call
1685 (Acceptor : Task_Id;
1686 E : Task_Entry_Index;
1687 Uninterpreted_Data : System.Address;
1690 Rendezvous_Successful : out Boolean)
1692 Self_Id : constant Task_Id := STPO.Self;
1694 Entry_Call : Entry_Call_Link;
1698 -- If pragma Detect_Blocking is active then Program_Error must be
1699 -- raised if this potentially blocking operation is called from a
1700 -- protected action.
1702 if System.Tasking.Detect_Blocking
1703 and then Self_Id.Common.Protected_Action_Nesting > 0
1705 Ada.Exceptions.Raise_Exception
1706 (Program_Error'Identity, "potentially blocking operation");
1709 Initialization.Defer_Abort (Self_Id);
1710 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1713 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1714 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A
'));
1716 if Parameters.Runtime_Traces then
1717 Send_Trace_Info (WT_Call, Acceptor,
1718 Entry_Index (E), Timeout);
1721 Level := Self_Id.ATC_Nesting_Level;
1722 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1723 Entry_Call.Next := null;
1724 Entry_Call.Mode := Timed_Call;
1725 Entry_Call.Cancellation_Attempted := False;
1727 -- If this is a call made inside of an abort deferred region,
1728 -- the call should be never abortable.
1730 if Self_Id.Deferral_Level > 1 then
1731 Entry_Call.State := Never_Abortable;
1733 Entry_Call.State := Now_Abortable;
1736 Entry_Call.E := Entry_Index (E);
1737 Entry_Call.Prio := Get_Priority (Self_Id);
1738 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1739 Entry_Call.Called_Task := Acceptor;
1740 Entry_Call.Called_PO := Null_Address;
1741 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1743 -- Note: the caller will undefer abortion on return (see WARNING above)
1749 if not Task_Do_Or_Queue
1750 (Self_Id, Entry_Call, With_Abort => True)
1752 STPO.Write_Lock (Self_Id);
1753 Utilities.Exit_One_ATC_Level (Self_Id);
1754 STPO.Unlock (Self_Id);
1760 Initialization.Undefer_Abort (Self_Id);
1762 if Parameters.Runtime_Traces then
1763 Send_Trace_Info (E_Missed, Acceptor);
1765 raise Tasking_Error;
1768 Write_Lock (Self_Id);
1769 Entry_Calls.Wait_For_Completion_With_Timeout
1770 (Entry_Call, Timeout, Mode, Yielded);
1777 -- ??? Do we need to yield in case Yielded is False
1779 Rendezvous_Successful := Entry_Call.State = Done;
1780 Initialization.Undefer_Abort (Self_Id);
1781 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1782 end Timed_Task_Entry_Call;
1788 procedure Wait_For_Call (Self_Id : Task_Id) is
1790 -- Try to remove calls to Sleep in the loop below by letting the caller
1791 -- a chance of getting ready immediately, using Unlock & Yield.
1792 -- See similar action in Wait_For_Completion & Selective_Wait.
1800 if Self_Id.Open_Accepts /= null then
1807 Write_Lock (Self_Id);
1810 -- Check if this task has been aborted while the lock was released.
1812 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1813 Self_Id.Open_Accepts := null;
1816 Self_Id.Common.State := Acceptor_Sleep;
1819 Initialization.Poll_Base_Priority_Change (Self_Id);
1821 exit when Self_Id.Open_Accepts = null;
1823 Sleep (Self_Id, Acceptor_Sleep);
1826 Self_Id.Common.State := Runnable;
1829 end System.Tasking.Rendezvous;