with Ada.Exceptions;
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.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, Accept_Alternative_Completed, Else_Selected,
Terminate_Selected,
Accept_Alternative_Open,
No_Alternative_Open);
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)
);
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;
procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
pragma Inline (Boost_Priority);
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);
procedure Setup_For_Rendezvous_With_Body
(Entry_Call : Entry_Call_Link;
Acceptor : Task_Id);
pragma Inline (Setup_For_Rendezvous_With_Body);
procedure Wait_For_Call (Self_Id : Task_Id);
pragma Inline (Wait_For_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);
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
Open_Accepts (1).Null_Body := False;
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_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
Uninterpreted_Data := System.Null_Address;
end if;
end if;
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;
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);
pragma Assert (False);
raise Standard'Abort_Signal;
end if;
Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
if Entry_Call = null then
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);
STPO.Unlock (Self_Id);
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);
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;
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;
procedure Call_Simple
(Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address)
is
Rendezvous_Successful : Boolean;
begin
if System.Tasking.Detect_Blocking
and then STPO.Self.Common.Protected_Action_Nesting > 0
then
Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "potentially blocking operation");
end if;
Call_Synchronous
(Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
end Call_Simple;
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 Self_Id.Deferral_Level > 1 then
Entry_Call.State := Never_Abortable;
else
Entry_Call.State := Now_Abortable;
end if;
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;
if Single_Lock then
Lock_RTS;
end if;
if not Task_Do_Or_Queue
(Self_Id, Entry_Call, With_Abort => True)
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;
Initialization.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;
function Callable (T : Task_Id) return Boolean is
Result : Boolean;
Self_Id : constant Task_Id := STPO.Self;
begin
Initialization.Defer_Abort (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 (Self_Id);
return Result;
end Callable;
procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
begin
Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled);
end Cancel_Task_Entry_Call;
procedure Complete_Rendezvous is
begin
Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id);
end Complete_Rendezvous;
procedure Exceptional_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;
Exception_To_Raise : Ada.Exceptions.Exception_Id := Ex;
Ceiling_Violation : Boolean;
use type Ada.Exceptions.Exception_Id;
procedure Internal_Reraise;
pragma Import (C, Internal_Reraise, "__gnat_reraise");
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
pragma Debug
(Debug.Trace (Self_Id, "Exceptional_Complete_Rendezvous", 'R'));
if Ex = Ada.Exceptions.Null_Id then
if Parameters.Runtime_Traces then
Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
end if;
Initialization.Defer_Abort_Nestable (Self_Id);
end if;
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;
Caller := Entry_Call.Self;
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
Entry_Call.Needs_Requeue := False;
Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
if Entry_Call.Called_Task /= null then
if Single_Lock then
Lock_RTS;
end if;
if not Task_Do_Or_Queue
(Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort)
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
Called_PO := POE.To_Protection (Entry_Call.Called_PO);
STPE.Lock_Entries (Called_PO, Ceiling_Violation);
if Ceiling_Violation then
pragma Assert (Ex = Ada.Exceptions.Null_Id);
Exception_To_Raise := Program_Error'Identity;
Entry_Call.Exception_To_Raise := Exception_To_Raise;
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,
Entry_Call.Requeue_With_Abort);
POO.PO_Service_Entries (Self_Id, Called_PO);
end if;
end if;
Entry_Calls.Reset_Priority
(Self_Id, Entry_Call.Acceptor_Prev_Priority);
else
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);
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;
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, Entry_Call.Acceptor_Prev_Priority);
end if;
end if;
Initialization.Undefer_Abort (Self_Id);
if Exception_To_Raise /= Ada.Exceptions.Null_Id then
Internal_Reraise;
end if;
end Exceptional_Complete_Rendezvous;
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.Requeue_With_Abort := With_Abort;
Object.Call_In_Progress := null;
end Requeue_Protected_To_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.Requeue_With_Abort := With_Abort;
Entry_Call.E := Entry_Index (E);
Entry_Call.Called_Task := Acceptor;
Initialization.Undefer_Abort (Self_Id);
end Requeue_Task_Entry;
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;
if Self_Id.Deferral_Level > 1 then
Self_Id.Deferral_Level := 1;
end if;
Initialization.Undefer_Abort (Self_Id);
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);
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;
case Treatment is
when Accept_Alternative_Selected =>
Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
pragma Assert (Self_Id.Deferral_Level = 1);
Initialization.Defer_Abort_Nestable (Self_Id);
STPO.Unlock (Self_Id);
when Accept_Alternative_Completed =>
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 =>
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);
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);
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 =>
Self_Id.Open_Accepts := Open_Accepts;
Self_Id.Common.State := Acceptor_Sleep;
STPO.Unlock (Self_Id);
Utilities.Make_Passive (Self_Id, Task_Completed => False);
STPO.Write_Lock (Self_Id);
Wait_For_Call (Self_Id);
pragma Assert (Self_Id.Open_Accepts = null);
if Self_Id.Terminate_Alternative then
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
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);
Initialization.Defer_Abort_Nestable (Self_Id);
end if;
end if;
STPO.Unlock (Self_Id);
when No_Alternative_Open =>
Self_Id.Open_Accepts := null;
if Select_Mode = Delay_Mode then
Self_Id.Common.State := Delay_Sleep;
loop
Initialization.Poll_Base_Priority_Change (Self_Id);
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);
Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "Entry call not a delay mode");
end if;
end case;
if Single_Lock then
Unlock_RTS;
end if;
Index := Self_Id.Chosen_Index;
Initialization.Undefer_Abort_Nestable (Self_Id);
end Selective_Wait;
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;
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;
function Task_Do_Or_Queue
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
With_Abort : Boolean) 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;
Parent_Locked : Boolean := False;
Null_Body : Boolean;
begin
pragma Assert (not Queuing.Onqueue (Entry_Call));
if Acceptor.Terminate_Alternative then
STPO.Write_Lock (Parent);
Parent_Locked := True;
end if;
STPO.Write_Lock (Acceptor);
if not Acceptor.Callable then
STPO.Unlock (Acceptor);
if Parent_Locked then
STPO.Unlock (Parent);
end if;
pragma Assert (Entry_Call.State < Done);
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;
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
Acceptor.Chosen_Index := J;
Null_Body := Acceptor.Open_Accepts (J).Null_Body;
Acceptor.Open_Accepts := null;
if Entry_Call.State = Now_Abortable then
Entry_Call.State := Was_Abortable;
end if;
if Acceptor.Terminate_Alternative then
Acceptor.Terminate_Alternative := False;
Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
if Acceptor.Awake_Count = 1 then
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
STPO.Wakeup (Acceptor, Acceptor_Sleep);
STPO.Unlock (Acceptor);
if Parent_Locked then
STPO.Unlock (Parent);
end if;
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);
if Acceptor.Common.State /= Runnable then
STPO.Wakeup (Acceptor, Acceptor_Sleep);
end if;
STPO.Unlock (Acceptor);
if Parent_Locked then
STPO.Unlock (Parent);
end if;
end if;
return True;
end if;
end loop;
end if;
if Entry_Call.Mode /= Conditional_Call
or else not With_Abort
then
Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
pragma Assert (Old_State < Done);
Entry_Call.State := New_State (With_Abort, Entry_Call.State);
STPO.Unlock (Acceptor);
if Parent_Locked then
STPO.Unlock (Parent);
end if;
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
then
STPO.Write_Lock (Entry_Call.Self);
if Entry_Call.Self.Common.State = Async_Select_Sleep then
STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
end if;
STPO.Unlock (Entry_Call.Self);
end if;
else
STPO.Unlock (Acceptor);
if Parent_Locked then
STPO.Unlock (Parent);
end if;
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);
end if;
return True;
end Task_Do_Or_Queue;
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 System.Tasking.Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "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
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;
if Single_Lock then
Lock_RTS;
end if;
if not Task_Do_Or_Queue
(Self_Id, Entry_Call, With_Abort => True)
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;
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;
Rendezvous_Successful := Entry_Call.State = Done;
end if;
end Task_Entry_Call;
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;
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 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);
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);
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;
case Treatment is
when Accept_Alternative_Selected =>
Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
Initialization.Defer_Abort (Self_Id);
STPO.Unlock (Self_Id);
when Accept_Alternative_Completed =>
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 =>
Self_Id.Open_Accepts := Open_Accepts;
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;
if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
Self_Id.Open_Accepts := null;
end if;
Self_Id.Common.State := Acceptor_Sleep;
loop
Initialization.Poll_Base_Priority_Change (Self_Id);
exit when Self_Id.Open_Accepts = null;
if Timedout then
Sleep (Self_Id, Acceptor_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_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;
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);
end if;
STPO.Unlock (Self_Id);
when No_Alternative_Open =>
Self_Id.Open_Accepts := null;
Self_Id.Common.State := Acceptor_Sleep;
Initialization.Poll_Base_Priority_Change (Self_Id);
STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
Timedout, Yielded);
Self_Id.Common.State := Runnable;
STPO.Unlock (Self_Id);
when others =>
pragma Assert (False);
null;
end case;
if Single_Lock then
Unlock_RTS;
end if;
if not Yielded then
Yield;
end if;
Index := Self_Id.Chosen_Index;
Initialization.Undefer_Abort_Nestable (Self_Id);
end Timed_Selective_Wait;
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;
begin
if System.Tasking.Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "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 Self_Id.Deferral_Level > 1 then
Entry_Call.State := Never_Abortable;
else
Entry_Call.State := Now_Abortable;
end if;
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;
if Single_Lock then
Lock_RTS;
end if;
if not Task_Do_Or_Queue
(Self_Id, Entry_Call, With_Abort => True)
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;
Rendezvous_Successful := Entry_Call.State = Done;
Initialization.Undefer_Abort (Self_Id);
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
end Timed_Task_Entry_Call;
procedure Wait_For_Call (Self_Id : Task_Id) is
begin
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;
if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
Self_Id.Open_Accepts := null;
end if;
Self_Id.Common.State := Acceptor_Sleep;
loop
Initialization.Poll_Base_Priority_Change (Self_Id);
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;