diff options
Diffstat (limited to 'gcc-4.9/gcc/ada/s-tasren.adb')
| -rw-r--r-- | gcc-4.9/gcc/ada/s-tasren.adb | 1809 |
1 files changed, 1809 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/s-tasren.adb b/gcc-4.9/gcc/ada/s-tasren.adb new file mode 100644 index 000000000..244f9e3d2 --- /dev/null +++ b/gcc-4.9/gcc/ada/s-tasren.adb @@ -0,0 +1,1809 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E N D E Z V O U S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives.Operations; +with System.Tasking.Entry_Calls; +with System.Tasking.Initialization; +with System.Tasking.Queuing; +with System.Tasking.Utilities; +with System.Tasking.Protected_Objects.Operations; +with System.Tasking.Debug; +with System.Restrictions; +with System.Parameters; +with System.Traces.Tasking; + +package body System.Tasking.Rendezvous is + + package STPO renames System.Task_Primitives.Operations; + package POO renames Protected_Objects.Operations; + package POE renames Protected_Objects.Entries; + + use Parameters; + use Task_Primitives.Operations; + use System.Traces; + use System.Traces.Tasking; + + type Select_Treatment is ( + Accept_Alternative_Selected, -- alternative with non-null body + Accept_Alternative_Completed, -- alternative with null body + Else_Selected, + Terminate_Selected, + Accept_Alternative_Open, + No_Alternative_Open); + + ---------------- + -- Local Data -- + ---------------- + + Default_Treatment : constant array (Select_Modes) of Select_Treatment := + (Simple_Mode => No_Alternative_Open, + Else_Mode => Else_Selected, + Terminate_Mode => Terminate_Selected, + Delay_Mode => No_Alternative_Open); + + New_State : constant array (Boolean, Entry_Call_State) + of Entry_Call_State := + (True => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Now_Abortable, + Was_Abortable => Now_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled), + False => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Not_Yet_Abortable, + Was_Abortable => Was_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled) + ); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Local_Defer_Abort (Self_Id : Task_Id) renames + System.Tasking.Initialization.Defer_Abort_Nestable; + + procedure Local_Undefer_Abort (Self_Id : Task_Id) renames + System.Tasking.Initialization.Undefer_Abort_Nestable; + + -- Florist defers abort around critical sections that make entry calls + -- to the Interrupt_Manager task, which violates the general rule about + -- top-level runtime system calls from abort-deferred regions. It is not + -- that this is unsafe, but when it occurs in "normal" programs it usually + -- means either the user is trying to do a potentially blocking operation + -- from within a protected object, or there is a runtime system/compiler + -- error that has failed to undefer an earlier abort deferral. Thus, for + -- debugging it may be wise to modify the above renamings to the + -- non-nestable forms. + + procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id); + -- Internal version of Complete_Rendezvous, used to implement + -- Complete_Rendezvous and Exceptional_Complete_Rendezvous. + -- Should be called holding no locks, generally with abort + -- not yet deferred. + + procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id); + pragma Inline (Boost_Priority); + -- Call this only with abort deferred and holding lock of Acceptor + + procedure Call_Synchronous + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean); + pragma Inline (Call_Synchronous); + -- This call is used to make a simple or conditional entry call. + -- Called from Call_Simple and Task_Entry_Call. + + procedure Setup_For_Rendezvous_With_Body + (Entry_Call : Entry_Call_Link; + Acceptor : Task_Id); + pragma Inline (Setup_For_Rendezvous_With_Body); + -- Call this only with abort deferred and holding lock of Acceptor. When + -- a rendezvous selected (ready for rendezvous) we need to save previous + -- caller and adjust the priority. Also we need to make this call not + -- Abortable (Cancellable) since the rendezvous has already been started. + + procedure Wait_For_Call (Self_Id : Task_Id); + pragma Inline (Wait_For_Call); + -- Call this only with abort deferred and holding lock of Self_Id. An + -- accepting task goes into Sleep by calling this routine waiting for a + -- call from the caller or waiting for an abort. Make sure Self_Id is + -- locked before calling this routine. + + ----------------- + -- Accept_Call -- + ----------------- + + procedure Accept_Call + (E : Task_Entry_Index; + Uninterpreted_Data : out System.Address) + is + Self_Id : constant Task_Id := STPO.Self; + Caller : Task_Id := null; + Open_Accepts : aliased Accept_List (1 .. 1); + Entry_Call : Entry_Call_Link; + + begin + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); + + if Entry_Call /= null then + Caller := Entry_Call.Self; + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Uninterpreted_Data := Entry_Call.Uninterpreted_Data; + + else + -- Wait for a caller + + Open_Accepts (1).Null_Body := False; + Open_Accepts (1).S := E; + Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; + + -- Wait for normal call + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length)); + end if; + + pragma Debug + (Debug.Trace (Self_Id, "Accept_Call: wait", 'R')); + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + if Self_Id.Common.Call /= null then + Caller := Self_Id.Common.Call.Self; + Uninterpreted_Data := + Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data; + else + -- Case of an aborted task + + Uninterpreted_Data := System.Null_Address; + end if; + end if; + + -- Self_Id.Common.Call should already be updated by the Caller. On + -- return, we will start the rendezvous. + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E)); + end if; + end Accept_Call; + + -------------------- + -- Accept_Trivial -- + -------------------- + + procedure Accept_Trivial (E : Task_Entry_Index) is + Self_Id : constant Task_Id := STPO.Self; + Caller : Task_Id := null; + Open_Accepts : aliased Accept_List (1 .. 1); + Entry_Call : Entry_Call_Link; + + begin + Initialization.Defer_Abort_Nestable (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); + + if Entry_Call = null then + + -- Need to wait for entry call + + Open_Accepts (1).Null_Body := True; + Open_Accepts (1).S := E; + Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length)); + end if; + + pragma Debug + (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R')); + + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + -- No need to do anything special here for pending abort. + -- Abort_Signal will be raised by Undefer on exit. + + STPO.Unlock (Self_Id); + + -- Found caller already waiting + + else + pragma Assert (Entry_Call.State < Done); + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + end if; + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Accept_Complete); + + -- Fake one, since there is (???) no way to know that the rendezvous + -- is over. + + Send_Trace_Info (M_RDV_Complete); + end if; + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_Id); + end Accept_Trivial; + + -------------------- + -- Boost_Priority -- + -------------------- + + procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is + Caller : constant Task_Id := Call.Self; + Caller_Prio : constant System.Any_Priority := Get_Priority (Caller); + Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor); + begin + if Caller_Prio > Acceptor_Prio then + Call.Acceptor_Prev_Priority := Acceptor_Prio; + Set_Priority (Acceptor, Caller_Prio); + else + Call.Acceptor_Prev_Priority := Priority_Not_Boosted; + end if; + end Boost_Priority; + + ----------------- + -- Call_Simple -- + ----------------- + + procedure Call_Simple + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address) + is + Rendezvous_Successful : Boolean; + pragma Unreferenced (Rendezvous_Successful); + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then STPO.Self.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + Call_Synchronous + (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful); + end Call_Simple; + + ---------------------- + -- Call_Synchronous -- + ---------------------- + + procedure Call_Synchronous + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Level : ATC_Level; + Entry_Call : Entry_Call_Link; + + begin + pragma Assert (Mode /= Asynchronous_Call); + + Local_Defer_Abort (Self_Id); + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_Id, "CS: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Level := Self_Id.ATC_Nesting_Level; + Entry_Call := Self_Id.Entry_Calls (Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Call, Acceptor, Entry_Index (E)); + end if; + + -- If this is a call made inside of an abort deferred region, + -- the call should be never abortable. + + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + -- Note: the caller will undefer abort on return (see WARNING above) + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + STPO.Write_Lock (Self_Id); + Utilities.Exit_One_ATC_Level (Self_Id); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Missed, Acceptor); + end if; + + Local_Undefer_Abort (Self_Id); + raise Tasking_Error; + end if; + + STPO.Write_Lock (Self_Id); + pragma Debug + (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R')); + Entry_Calls.Wait_For_Completion (Entry_Call); + pragma Debug + (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R')); + Rendezvous_Successful := Entry_Call.State = Done; + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Local_Undefer_Abort (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + end Call_Synchronous; + + -------------- + -- Callable -- + -------------- + + function Callable (T : Task_Id) return Boolean is + Result : Boolean; + Self_Id : constant Task_Id := STPO.Self; + + begin + Initialization.Defer_Abort_Nestable (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (T); + Result := T.Callable; + STPO.Unlock (T); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_Id); + return Result; + end Callable; + + ---------------------------- + -- Cancel_Task_Entry_Call -- + ---------------------------- + + procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is + begin + Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled); + end Cancel_Task_Entry_Call; + + ------------------------- + -- Complete_Rendezvous -- + ------------------------- + + procedure Complete_Rendezvous is + begin + Local_Complete_Rendezvous (Ada.Exceptions.Null_Id); + end Complete_Rendezvous; + + ------------------------------------- + -- Exceptional_Complete_Rendezvous -- + ------------------------------------- + + procedure Exceptional_Complete_Rendezvous + (Ex : Ada.Exceptions.Exception_Id) + is + procedure Internal_Reraise; + pragma No_Return (Internal_Reraise); + pragma Import (C, Internal_Reraise, "__gnat_reraise"); + + begin + Local_Complete_Rendezvous (Ex); + Internal_Reraise; + + -- ??? Do we need to give precedence to Program_Error that might be + -- raised due to failure of finalization, over Tasking_Error from + -- failure of requeue? + end Exceptional_Complete_Rendezvous; + + ------------------------------- + -- Local_Complete_Rendezvous -- + ------------------------------- + + procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link := Self_Id.Common.Call; + Caller : Task_Id; + Called_PO : STPE.Protection_Entries_Access; + Acceptor_Prev_Priority : Integer; + + Ceiling_Violation : Boolean; + + use type Ada.Exceptions.Exception_Id; + procedure Transfer_Occurrence + (Target : Ada.Exceptions.Exception_Occurrence_Access; + Source : Ada.Exceptions.Exception_Occurrence); + pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); + + use type STPE.Protection_Entries_Access; + + begin + -- The deferral level is critical here, since we want to raise an + -- exception or allow abort to take place, if there is an exception or + -- abort pending. + + pragma Debug + (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R')); + + if Ex = Ada.Exceptions.Null_Id then + + -- The call came from normal end-of-rendezvous, so abort is not yet + -- deferred. + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); + end if; + + Initialization.Defer_Abort (Self_Id); + + elsif ZCX_By_Default then + + -- With ZCX, aborts are not automatically deferred in handlers + + Initialization.Defer_Abort (Self_Id); + end if; + + -- We need to clean up any accepts which Self may have been serving when + -- it was aborted. + + if Ex = Standard'Abort_Signal'Identity then + if Single_Lock then + Lock_RTS; + end if; + + while Entry_Call /= null loop + Entry_Call.Exception_To_Raise := Tasking_Error'Identity; + + -- All forms of accept make sure that the acceptor is not + -- completed, before accepting further calls, so that we + -- can be sure that no further calls are made after the + -- current calls are purged. + + Caller := Entry_Call.Self; + + -- Take write lock. This follows the lock precedence rule that + -- Caller may be locked while holding lock of Acceptor. Complete + -- the call abnormally, with exception. + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + Entry_Call := Entry_Call.Acceptor_Prev_Call; + end loop; + + if Single_Lock then + Unlock_RTS; + end if; + + else + Caller := Entry_Call.Self; + + if Entry_Call.Needs_Requeue then + + -- We dare not lock Self_Id at the same time as Caller, for fear + -- of deadlock. + + Entry_Call.Needs_Requeue := False; + Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; + + if Entry_Call.Called_Task /= null then + + -- Requeue to another task entry + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + raise Tasking_Error; + end if; + + if Single_Lock then + Unlock_RTS; + end if; + + else + -- Requeue to a protected entry + + Called_PO := POE.To_Protection (Entry_Call.Called_PO); + STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation); + + if Ceiling_Violation then + pragma Assert (Ex = Ada.Exceptions.Null_Id); + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller + (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + if Single_Lock then + Unlock_RTS; + end if; + + else + POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call); + POO.PO_Service_Entries (Self_Id, Called_PO); + end if; + end if; + + Entry_Calls.Reset_Priority + (Self_Id, Entry_Call.Acceptor_Prev_Priority); + + else + -- The call does not need to be requeued + + Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; + Entry_Call.Exception_To_Raise := Ex; + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + + -- Done with Caller locked to make sure that Wakeup is not lost + + if Ex /= Ada.Exceptions.Null_Id then + Transfer_Occurrence + (Caller.Common.Compiler_Data.Current_Excep'Access, + Self_Id.Common.Compiler_Data.Current_Excep); + end if; + + Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority; + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + + STPO.Unlock (Caller); + + if Single_Lock then + Unlock_RTS; + end if; + + Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority); + end if; + end if; + + Initialization.Undefer_Abort (Self_Id); + end Local_Complete_Rendezvous; + + ------------------------------------- + -- Requeue_Protected_To_Task_Entry -- + ------------------------------------- + + procedure Requeue_Protected_To_Task_Entry + (Object : STPE.Protection_Entries_Access; + Acceptor : Task_Id; + E : Task_Entry_Index; + With_Abort : Boolean) + is + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + begin + pragma Assert (STPO.Self.Deferral_Level > 0); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.With_Abort := With_Abort; + Object.Call_In_Progress := null; + end Requeue_Protected_To_Task_Entry; + + ------------------------ + -- Requeue_Task_Entry -- + ------------------------ + + procedure Requeue_Task_Entry + (Acceptor : Task_Id; + E : Task_Entry_Index; + With_Abort : Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call; + begin + Initialization.Defer_Abort (Self_Id); + Entry_Call.Needs_Requeue := True; + Entry_Call.With_Abort := With_Abort; + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_Task := Acceptor; + Initialization.Undefer_Abort (Self_Id); + end Requeue_Task_Entry; + + -------------------- + -- Selective_Wait -- + -------------------- + + procedure Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Index : out Select_Index) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + Treatment : Select_Treatment; + Caller : Task_Id; + Selection : Select_Index; + Open_Alternative : Boolean; + + begin + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + -- ??? In some cases abort is deferred more than once. Need to + -- figure out why this happens. + + if Self_Id.Deferral_Level > 1 then + Self_Id.Deferral_Level := 1; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + pragma Assert (Open_Accepts /= null); + + Uninterpreted_Data := Null_Address; + + Queuing.Select_Task_Entry_Call + (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); + + -- Determine the kind and disposition of the select + + Treatment := Default_Treatment (Select_Mode); + Self_Id.Chosen_Index := No_Rendezvous; + + if Open_Alternative then + if Entry_Call /= null then + if Open_Accepts (Selection).Null_Body then + Treatment := Accept_Alternative_Completed; + else + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Treatment := Accept_Alternative_Selected; + end if; + + Self_Id.Chosen_Index := Selection; + + elsif Treatment = No_Alternative_Open then + Treatment := Accept_Alternative_Open; + end if; + end if; + + -- Handle the select according to the disposition selected above + + case Treatment is + when Accept_Alternative_Selected => + + -- Ready to rendezvous + + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + -- In this case the accept body is not Null_Body. Defer abort + -- until it gets into the accept body. The compiler has inserted + -- a call to Abort_Undefer as part of the entry expansion. + + pragma Assert (Self_Id.Deferral_Level = 1); + + Initialization.Defer_Abort_Nestable (Self_Id); + STPO.Unlock (Self_Id); + + when Accept_Alternative_Completed => + + -- Accept body is null, so rendezvous is over immediately + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); + end if; + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + when Accept_Alternative_Open => + + -- Wait for caller + + Self_Id.Open_Accepts := Open_Accepts; + pragma Debug + (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Select, Self_Id, + Integer (Open_Accepts'Length)); + end if; + + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + -- Self_Id.Common.Call should already be updated by the Caller if + -- not aborted. It might also be ready to do rendezvous even if + -- this wakes up due to an abort. Therefore, if the call is not + -- empty we need to do the rendezvous if the accept body is not + -- Null_Body. + + -- Aren't the first two conditions below redundant??? + + if Self_Id.Chosen_Index /= No_Rendezvous + and then Self_Id.Common.Call /= null + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert + (Self_Id.Deferral_Level = 1 + or else + (Self_Id.Deferral_Level = 0 + and then not Restrictions.Abort_Allowed)); + + Initialization.Defer_Abort_Nestable (Self_Id); + + -- Leave abort deferred until the accept body + -- The compiler has inserted a call to Abort_Undefer as part of + -- the entry expansion. + end if; + + STPO.Unlock (Self_Id); + + when Else_Selected => + pragma Assert (Self_Id.Open_Accepts = null); + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Select_Else); + end if; + + STPO.Unlock (Self_Id); + + when Terminate_Selected => + + -- Terminate alternative is open + + Self_Id.Open_Accepts := Open_Accepts; + Self_Id.Common.State := Acceptor_Sleep; + + -- Notify ancestors that this task is on a terminate alternative + + STPO.Unlock (Self_Id); + Utilities.Make_Passive (Self_Id, Task_Completed => False); + STPO.Write_Lock (Self_Id); + + -- Wait for normal entry call or termination + + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + if Self_Id.Terminate_Alternative then + + -- An entry call should have reset this to False, so we must be + -- aborted. We cannot be in an async. select, since that is not + -- legal, so the abort must be of the entire task. Therefore, + -- we do not need to cancel the terminate alternative. The + -- cleanup will be done in Complete_Master. + + pragma Assert (Self_Id.Pending_ATC_Level = 0); + pragma Assert (Self_Id.Awake_Count = 0); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Index := Self_Id.Chosen_Index; + Initialization.Undefer_Abort_Nestable (Self_Id); + + if Self_Id.Pending_Action then + Initialization.Do_Pending_Action (Self_Id); + end if; + + return; + + else + -- Self_Id.Common.Call and Self_Id.Chosen_Index + -- should already be updated by the Caller. + + if Self_Id.Chosen_Index /= No_Rendezvous + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert (Self_Id.Deferral_Level = 1); + + -- We need an extra defer here, to keep abort + -- deferred until we get into the accept body + -- The compiler has inserted a call to Abort_Undefer as part + -- of the entry expansion. + + Initialization.Defer_Abort_Nestable (Self_Id); + end if; + end if; + + STPO.Unlock (Self_Id); + + when No_Alternative_Open => + + -- In this case, Index will be No_Rendezvous on return, which + -- should cause a Program_Error if it is not a Delay_Mode. + + -- If delay alternative exists (Delay_Mode) we should suspend + -- until the delay expires. + + Self_Id.Open_Accepts := null; + + if Select_Mode = Delay_Mode then + Self_Id.Common.State := Delay_Sleep; + + loop + exit when + Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level; + Sleep (Self_Id, Delay_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + STPO.Unlock (Self_Id); + + else + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + raise Program_Error with "Entry call not a delay mode"; + end if; + end case; + + if Single_Lock then + Unlock_RTS; + end if; + + -- Caller has been chosen + + -- Self_Id.Common.Call should already be updated by the Caller. + + -- Self_Id.Chosen_Index should either be updated by the Caller + -- or by Test_Selective_Wait. + + -- On return, we sill start rendezvous unless the accept body is + -- null. In the latter case, we will have already completed the RV. + + Index := Self_Id.Chosen_Index; + Initialization.Undefer_Abort_Nestable (Self_Id); + end Selective_Wait; + + ------------------------------------ + -- Setup_For_Rendezvous_With_Body -- + ------------------------------------ + + procedure Setup_For_Rendezvous_With_Body + (Entry_Call : Entry_Call_Link; + Acceptor : Task_Id) is + begin + Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call; + Acceptor.Common.Call := Entry_Call; + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Boost_Priority (Entry_Call, Acceptor); + end Setup_For_Rendezvous_With_Body; + + ---------------- + -- Task_Count -- + ---------------- + + function Task_Count (E : Task_Entry_Index) return Natural is + Self_Id : constant Task_Id := STPO.Self; + Return_Count : Natural; + + begin + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E)); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + return Return_Count; + end Task_Count; + + ---------------------- + -- Task_Do_Or_Queue -- + ---------------------- + + function Task_Do_Or_Queue + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) return Boolean + is + E : constant Task_Entry_Index := + Task_Entry_Index (Entry_Call.E); + Old_State : constant Entry_Call_State := Entry_Call.State; + Acceptor : constant Task_Id := Entry_Call.Called_Task; + Parent : constant Task_Id := Acceptor.Common.Parent; + Null_Body : Boolean; + + begin + -- Find out whether Entry_Call can be accepted immediately + + -- If the Acceptor is not callable, return False. + -- If the rendezvous can start, initiate it. + -- If the accept-body is trivial, also complete the rendezvous. + -- If the acceptor is not ready, enqueue the call. + + -- This should have a special case for Accept_Call and Accept_Trivial, + -- so that we don't have the loop setup overhead, below. + + -- The call state Done is used here and elsewhere to include both the + -- case of normal successful completion, and the case of an exception + -- being raised. The difference is that if an exception is raised no one + -- will pay attention to the fact that State = Done. Instead the + -- exception will be raised in Undefer_Abort, and control will skip past + -- the place where we normally would resume from an entry call. + + pragma Assert (not Queuing.Onqueue (Entry_Call)); + + -- We rely that the call is off-queue for protection, that the caller + -- will not exit the Entry_Caller_Sleep, and so will not reuse the call + -- record for another call. We rely on the Caller's lock for call State + -- mod's. + + -- If Acceptor.Terminate_Alternative is True, we need to lock Parent and + -- Acceptor, in that order; otherwise, we only need a lock on Acceptor. + -- However, we can't check Acceptor.Terminate_Alternative until Acceptor + -- is locked. Therefore, we need to lock both. Attempts to avoid locking + -- Parent tend to result in race conditions. It would work to unlock + -- Parent immediately upon finding Acceptor.Terminate_Alternative to be + -- False, but that violates the rule of properly nested locking (see + -- System.Tasking). + + STPO.Write_Lock (Parent); + STPO.Write_Lock (Acceptor); + + -- If the acceptor is not callable, abort the call and return False + + if not Acceptor.Callable then + STPO.Unlock (Acceptor); + STPO.Unlock (Parent); + + pragma Assert (Entry_Call.State < Done); + + -- In case we are not the caller, set up the caller + -- to raise Tasking_Error when it wakes up. + + STPO.Write_Lock (Entry_Call.Self); + Entry_Call.Exception_To_Raise := Tasking_Error'Identity; + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + return False; + end if; + + -- Try to serve the call immediately + + if Acceptor.Open_Accepts /= null then + for J in Acceptor.Open_Accepts'Range loop + if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then + + -- Commit acceptor to rendezvous with us + + Acceptor.Chosen_Index := J; + Null_Body := Acceptor.Open_Accepts (J).Null_Body; + Acceptor.Open_Accepts := null; + + -- Prevent abort while call is being served + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + if Acceptor.Terminate_Alternative then + + -- Cancel terminate alternative. See matching code in + -- Selective_Wait and Vulnerable_Complete_Master. + + Acceptor.Terminate_Alternative := False; + Acceptor.Awake_Count := Acceptor.Awake_Count + 1; + + if Acceptor.Awake_Count = 1 then + + -- Notify parent that acceptor is awake + + pragma Assert (Parent.Awake_Count > 0); + + Parent.Awake_Count := Parent.Awake_Count + 1; + + if Parent.Common.State = Master_Completion_Sleep + and then Acceptor.Master_of_Task = Parent.Master_Within + then + Parent.Common.Wait_Count := + Parent.Common.Wait_Count + 1; + end if; + end if; + end if; + + if Null_Body then + + -- Rendezvous is over immediately + + STPO.Wakeup (Acceptor, Acceptor_Sleep); + STPO.Unlock (Acceptor); + STPO.Unlock (Parent); + + STPO.Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller + (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + else + Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor); + + -- For terminate_alternative, acceptor may not be asleep + -- yet, so we skip the wakeup + + if Acceptor.Common.State /= Runnable then + STPO.Wakeup (Acceptor, Acceptor_Sleep); + end if; + + STPO.Unlock (Acceptor); + STPO.Unlock (Parent); + end if; + + return True; + end if; + end loop; + + -- The acceptor is accepting, but not this entry + end if; + + -- If the acceptor was ready to accept this call, + -- we would not have gotten this far, so now we should + -- (re)enqueue the call, if the mode permits that. + + -- If the call is timed, it may have timed out before the requeue, + -- in the unusual case where the current accept has taken longer than + -- the given delay. In that case the requeue is cancelled, and the + -- outer timed call will be aborted. + + if Entry_Call.Mode = Conditional_Call + or else + (Entry_Call.Mode = Timed_Call + and then Entry_Call.With_Abort + and then Entry_Call.Cancellation_Attempted) + then + STPO.Unlock (Acceptor); + STPO.Unlock (Parent); + + STPO.Write_Lock (Entry_Call.Self); + + pragma Assert (Entry_Call.State >= Was_Abortable); + + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); + STPO.Unlock (Entry_Call.Self); + + else + -- Timed_Call, Simple_Call, or Asynchronous_Call + + Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call); + + -- Update abortability of call + + pragma Assert (Old_State < Done); + + Entry_Call.State := + New_State (Entry_Call.With_Abort, Entry_Call.State); + + STPO.Unlock (Acceptor); + STPO.Unlock (Parent); + + if Old_State /= Entry_Call.State + and then Entry_Call.State = Now_Abortable + and then Entry_Call.Mode /= Simple_Call + and then Entry_Call.Self /= Self_ID + + -- Asynchronous_Call or Conditional_Call + + then + -- Because of ATCB lock ordering rule + + STPO.Write_Lock (Entry_Call.Self); + + if Entry_Call.Self.Common.State = Async_Select_Sleep then + + -- Caller may not yet have reached wait-point + + STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); + end if; + + STPO.Unlock (Entry_Call.Self); + end if; + end if; + + return True; + end Task_Do_Or_Queue; + + --------------------- + -- Task_Entry_Call -- + --------------------- + + procedure Task_Entry_Call + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Call, Acceptor, Entry_Index (E)); + end if; + + if Mode = Simple_Call or else Mode = Conditional_Call then + Call_Synchronous + (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful); + + else + -- This is an asynchronous call + + -- Abort must already be deferred by the compiler-generated code. + -- Without this, an abort that occurs between the time that this + -- call is made and the time that the abortable part's cleanup + -- handler is set up might miss the cleanup handler and leave the + -- call pending. + + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_Id, "TEC: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + Entry_Call.State := Not_Yet_Abortable; + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + STPO.Write_Lock (Self_Id); + Utilities.Exit_One_ATC_Level (Self_Id); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Missed, Acceptor); + end if; + + raise Tasking_Error; + end if; + + -- The following is special for async. entry calls. If the call was + -- not queued abortably, we need to wait until it is before + -- proceeding with the abortable part. + + -- Wait_Until_Abortable can be called unconditionally here, but it is + -- expensive. + + if Entry_Call.State < Was_Abortable then + Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call); + end if; + + if Single_Lock then + Unlock_RTS; + end if; + + -- Note: following assignment needs to be atomic + + Rendezvous_Successful := Entry_Call.State = Done; + end if; + end Task_Entry_Call; + + ----------------------- + -- Task_Entry_Caller -- + ----------------------- + + function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + + begin + Entry_Call := Self_Id.Common.Call; + + for Depth in 1 .. D loop + Entry_Call := Entry_Call.Acceptor_Prev_Call; + pragma Assert (Entry_Call /= null); + end loop; + + return Entry_Call.Self; + end Task_Entry_Caller; + + -------------------------- + -- Timed_Selective_Wait -- + -------------------------- + + procedure Timed_Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Index : out Select_Index) + is + Self_Id : constant Task_Id := STPO.Self; + Treatment : Select_Treatment; + Entry_Call : Entry_Call_Link; + Caller : Task_Id; + Selection : Select_Index; + Open_Alternative : Boolean; + Timedout : Boolean := False; + Yielded : Boolean := True; + + begin + pragma Assert (Select_Mode = Delay_Mode); + + Initialization.Defer_Abort (Self_Id); + + -- If we are aborted here, the effect will be pending + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Uninterpreted_Data := Null_Address; + + pragma Assert (Open_Accepts /= null); + + Queuing.Select_Task_Entry_Call + (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); + + -- Determine the kind and disposition of the select + + Treatment := Default_Treatment (Select_Mode); + Self_Id.Chosen_Index := No_Rendezvous; + + if Open_Alternative then + if Entry_Call /= null then + if Open_Accepts (Selection).Null_Body then + Treatment := Accept_Alternative_Completed; + + else + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Treatment := Accept_Alternative_Selected; + end if; + + Self_Id.Chosen_Index := Selection; + + elsif Treatment = No_Alternative_Open then + Treatment := Accept_Alternative_Open; + end if; + end if; + + -- Handle the select according to the disposition selected above + + case Treatment is + when Accept_Alternative_Selected => + + -- Ready to rendezvous. In this case the accept body is not + -- Null_Body. Defer abort until it gets into the accept body. + + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + Initialization.Defer_Abort_Nestable (Self_Id); + STPO.Unlock (Self_Id); + + when Accept_Alternative_Completed => + + -- Rendezvous is over + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); + end if; + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + when Accept_Alternative_Open => + + -- Wait for caller + + Self_Id.Open_Accepts := Open_Accepts; + + -- Wait for a normal call and a pending action until the + -- Wakeup_Time is reached. + + Self_Id.Common.State := Acceptor_Delay_Sleep; + + -- Try to remove calls to Sleep in the loop below by letting the + -- caller a chance of getting ready immediately, using Unlock + -- Yield. See similar action in Wait_For_Completion/Wait_For_Call. + + if Single_Lock then + Unlock_RTS; + else + Unlock (Self_Id); + end if; + + if Self_Id.Open_Accepts /= null then + Yield; + end if; + + if Single_Lock then + Lock_RTS; + else + Write_Lock (Self_Id); + end if; + + -- Check if this task has been aborted while the lock was released + + if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then + Self_Id.Open_Accepts := null; + end if; + + loop + exit when Self_Id.Open_Accepts = null; + + if Timedout then + Sleep (Self_Id, Acceptor_Delay_Sleep); + else + if Parameters.Runtime_Traces then + Send_Trace_Info (WT_Select, + Self_Id, + Integer (Open_Accepts'Length), + Timeout); + end if; + + STPO.Timed_Sleep (Self_Id, Timeout, Mode, + Acceptor_Delay_Sleep, Timedout, Yielded); + end if; + + if Timedout then + Self_Id.Open_Accepts := null; + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Timeout); + end if; + end if; + end loop; + + Self_Id.Common.State := Runnable; + + -- Self_Id.Common.Call should already be updated by the Caller if + -- not aborted. It might also be ready to do rendezvous even if + -- this wakes up due to an abort. Therefore, if the call is not + -- empty we need to do the rendezvous if the accept body is not + -- Null_Body. + + if Self_Id.Chosen_Index /= No_Rendezvous + and then Self_Id.Common.Call /= null + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert (Self_Id.Deferral_Level = 1); + + Initialization.Defer_Abort_Nestable (Self_Id); + + -- Leave abort deferred until the accept body + end if; + + STPO.Unlock (Self_Id); + + when No_Alternative_Open => + + -- In this case, Index will be No_Rendezvous on return. We sleep + -- for the time we need to. + + -- Wait for a signal or timeout. A wakeup can be made + -- for several reasons: + -- 1) Delay is expired + -- 2) Pending_Action needs to be checked + -- (Abort, Priority change) + -- 3) Spurious wakeup + + Self_Id.Open_Accepts := null; + Self_Id.Common.State := Acceptor_Delay_Sleep; + + STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep, + Timedout, Yielded); + + Self_Id.Common.State := Runnable; + + STPO.Unlock (Self_Id); + + when others => + + -- Should never get here + + pragma Assert (False); + null; + end case; + + if Single_Lock then + Unlock_RTS; + end if; + + if not Yielded then + Yield; + end if; + + -- Caller has been chosen + + -- Self_Id.Common.Call should already be updated by the Caller + + -- Self_Id.Chosen_Index should either be updated by the Caller + -- or by Test_Selective_Wait + + Index := Self_Id.Chosen_Index; + Initialization.Undefer_Abort_Nestable (Self_Id); + + -- Start rendezvous, if not already completed + end Timed_Selective_Wait; + + --------------------------- + -- Timed_Task_Entry_Call -- + --------------------------- + + procedure Timed_Task_Entry_Call + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Level : ATC_Level; + Entry_Call : Entry_Call_Link; + + Yielded : Boolean; + pragma Unreferenced (Yielded); + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + Initialization.Defer_Abort (Self_Id); + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + + pragma Debug + (Debug.Trace (Self_Id, "TTEC: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + + if Parameters.Runtime_Traces then + Send_Trace_Info (WT_Call, Acceptor, + Entry_Index (E), Timeout); + end if; + + Level := Self_Id.ATC_Nesting_Level; + Entry_Call := Self_Id.Entry_Calls (Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Timed_Call; + Entry_Call.Cancellation_Attempted := False; + + -- If this is a call made inside of an abort deferred region, + -- the call should be never abortable. + + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + -- Note: the caller will undefer abort on return (see WARNING above) + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + STPO.Write_Lock (Self_Id); + Utilities.Exit_One_ATC_Level (Self_Id); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Missed, Acceptor); + end if; + raise Tasking_Error; + end if; + + Write_Lock (Self_Id); + Entry_Calls.Wait_For_Completion_With_Timeout + (Entry_Call, Timeout, Mode, Yielded); + Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + -- ??? Do we need to yield in case Yielded is False + + Rendezvous_Successful := Entry_Call.State = Done; + Initialization.Undefer_Abort (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + end Timed_Task_Entry_Call; + + ------------------- + -- Wait_For_Call -- + ------------------- + + procedure Wait_For_Call (Self_Id : Task_Id) is + begin + Self_Id.Common.State := Acceptor_Sleep; + + -- Try to remove calls to Sleep in the loop below by letting the caller + -- a chance of getting ready immediately, using Unlock & Yield. + -- See similar action in Wait_For_Completion & Timed_Selective_Wait. + + if Single_Lock then + Unlock_RTS; + else + Unlock (Self_Id); + end if; + + if Self_Id.Open_Accepts /= null then + Yield; + end if; + + if Single_Lock then + Lock_RTS; + else + Write_Lock (Self_Id); + end if; + + -- Check if this task has been aborted while the lock was released + + if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then + Self_Id.Open_Accepts := null; + end if; + + loop + exit when Self_Id.Open_Accepts = null; + Sleep (Self_Id, Acceptor_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + end Wait_For_Call; + +end System.Tasking.Rendezvous; |