with Ada.Exceptions;
with System.Task_Primitives.Operations;
with System.Tasking.Entry_Calls;
with System.Tasking.Initialization;
pragma Elaborate_All (System.Tasking.Initialization);
with System.Tasking.Queuing;
with System.Tasking.Rendezvous;
with System.Tasking.Debug;
with System.Parameters;
with System.Traces.Tasking;
package body System.Tasking.Protected_Objects.Operations is
package STPO renames System.Task_Primitives.Operations;
use Parameters;
use Task_Primitives;
use Ada.Exceptions;
use Entries;
use System.Traces;
use System.Traces.Tasking;
procedure Update_For_Queue_To_PO
(Entry_Call : Entry_Call_Link;
With_Abort : Boolean);
pragma Inline (Update_For_Queue_To_PO);
procedure Cancel_Protected_Entry_Call
(Block : in out Communication_Block) is
begin
Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled);
end Cancel_Protected_Entry_Call;
function Cancelled (Block : Communication_Block) return Boolean is
begin
return Block.Cancelled;
end Cancelled;
procedure Complete_Entry_Body (Object : Protection_Entries_Access) is
begin
Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id);
end Complete_Entry_Body;
function Enqueued (Block : Communication_Block) return Boolean is
begin
return Block.Enqueued;
end Enqueued;
procedure Exceptional_Complete_Entry_Body
(Object : Protection_Entries_Access;
Ex : Ada.Exceptions.Exception_Id)
is
Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
begin
pragma Debug
(Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P'));
if Entry_Call /= null then
Entry_Call.Exception_To_Raise := Ex;
end if;
if Runtime_Traces then
Send_Trace_Info (PO_Done, Entry_Call.Self);
end if;
end Exceptional_Complete_Entry_Body;
procedure PO_Do_Or_Queue
(Self_ID : Task_ID;
Object : Protection_Entries_Access;
Entry_Call : Entry_Call_Link;
With_Abort : Boolean)
is
E : Protected_Entry_Index := Protected_Entry_Index (Entry_Call.E);
New_Object : Protection_Entries_Access;
Ceiling_Violation : Boolean;
Barrier_Value : Boolean;
Result : Boolean;
begin
Barrier_Value :=
Object.Entry_Bodies (
Object.Find_Body_Index (Object.Compiler_Info, E)).
Barrier (Object.Compiler_Info, E);
if Barrier_Value then
if Entry_Call.State = Now_Abortable then
Entry_Call.State := Was_Abortable;
end if;
Object.Call_In_Progress := Entry_Call;
pragma Debug
(Debug.Trace (Self_ID, "PODOQ: start entry body", 'P'));
Object.Entry_Bodies (
Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
if Object.Call_In_Progress /= null then
Object.Call_In_Progress := null;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Entry_Call.Self);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
else
New_Object := To_Protection (Entry_Call.Called_PO);
if New_Object = null then
if Single_Lock then
STPO.Lock_RTS;
end if;
Result := Rendezvous.Task_Do_Or_Queue
(Self_ID, Entry_Call,
With_Abort => Entry_Call.Requeue_With_Abort);
if not Result then
Queuing.Broadcast_Program_Error
(Self_ID, Object, Entry_Call, RTS_Locked => True);
end if;
if Single_Lock then
STPO.Unlock_RTS;
end if;
return;
end if;
if Object /= New_Object then
Lock_Entries (New_Object, Ceiling_Violation);
if Ceiling_Violation then
Object.Call_In_Progress := null;
Queuing.Broadcast_Program_Error
(Self_ID, Object, Entry_Call);
else
PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, With_Abort);
PO_Service_Entries (Self_ID, New_Object);
Unlock_Entries (New_Object);
end if;
else
if Entry_Call.Requeue_With_Abort
and then Entry_Call.Cancellation_Attempted
then
Entry_Call.State := Cancelled;
return;
end if;
if not With_Abort or else
Entry_Call.Mode /= Conditional_Call
then
E := Protected_Entry_Index (Entry_Call.E);
Queuing.Enqueue
(New_Object.Entry_Queues (E), Entry_Call);
Update_For_Queue_To_PO (Entry_Call, With_Abort);
else
PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, With_Abort);
end if;
end if;
end if;
elsif Entry_Call.Mode /= Conditional_Call or else
not With_Abort then
Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
Update_For_Queue_To_PO (Entry_Call, With_Abort);
else
if Single_Lock then
STPO.Lock_RTS;
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);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
exception
when others =>
Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call);
end PO_Do_Or_Queue;
procedure PO_Service_Entries
(Self_ID : Task_ID;
Object : Protection_Entries_Access)
is
Entry_Call : Entry_Call_Link;
E : Protected_Entry_Index;
Caller : Task_ID;
New_Object : Protection_Entries_Access;
Ceiling_Violation : Boolean;
Result : Boolean;
begin
loop
Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call);
if Entry_Call /= null then
E := Protected_Entry_Index (Entry_Call.E);
if Entry_Call.State = Now_Abortable then
Entry_Call.State := Was_Abortable;
end if;
Object.Call_In_Progress := Entry_Call;
begin
if Runtime_Traces then
Send_Trace_Info (PO_Run, Self_ID,
Entry_Call.Self, Entry_Index (E));
end if;
pragma Debug
(Debug.Trace (Self_ID, "POSE: start entry body", 'P'));
Object.Entry_Bodies (
Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
exception
when others =>
Queuing.Broadcast_Program_Error
(Self_ID, Object, Entry_Call);
end;
if Object.Call_In_Progress /= null then
Object.Call_In_Progress := null;
Caller := Entry_Call.Self;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Caller);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
STPO.Unlock (Caller);
if Single_Lock then
STPO.Unlock_RTS;
end if;
else
New_Object := To_Protection (Entry_Call.Called_PO);
if New_Object = null then
if Single_Lock then
STPO.Lock_RTS;
end if;
Result := Rendezvous.Task_Do_Or_Queue
(Self_ID, Entry_Call,
With_Abort => Entry_Call.Requeue_With_Abort);
if not Result then
Queuing.Broadcast_Program_Error
(Self_ID, Object, Entry_Call, RTS_Locked => True);
end if;
if Single_Lock then
STPO.Unlock_RTS;
end if;
else
if Object /= New_Object then
Lock_Entries (New_Object, Ceiling_Violation);
if Ceiling_Violation then
Object.Call_In_Progress := null;
Queuing.Broadcast_Program_Error
(Self_ID, Object, Entry_Call);
else
PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call,
Entry_Call.Requeue_With_Abort);
PO_Service_Entries (Self_ID, New_Object);
Unlock_Entries (New_Object);
end if;
else
STPO.Yield (False);
if Entry_Call.Requeue_With_Abort
and then Entry_Call.Cancellation_Attempted
then
Entry_Call.State := Cancelled;
exit;
end if;
if not Entry_Call.Requeue_With_Abort or else
Entry_Call.Mode /= Conditional_Call
then
E := Protected_Entry_Index (Entry_Call.E);
Queuing.Enqueue
(New_Object.Entry_Queues (E), Entry_Call);
Update_For_Queue_To_PO (Entry_Call,
Entry_Call.Requeue_With_Abort);
else
PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call,
Entry_Call.Requeue_With_Abort);
end if;
end if;
end if;
end if;
else
exit;
end if;
end loop;
end PO_Service_Entries;
function Protected_Count
(Object : Protection_Entries'Class;
E : Protected_Entry_Index)
return Natural
is
begin
return Queuing.Count_Waiting (Object.Entry_Queues (E));
end Protected_Count;
procedure Protected_Entry_Call
(Object : Protection_Entries_Access;
E : Protected_Entry_Index;
Uninterpreted_Data : System.Address;
Mode : Call_Modes;
Block : out Communication_Block)
is
Self_ID : Task_ID := STPO.Self;
Entry_Call : Entry_Call_Link;
Initially_Abortable : Boolean;
Ceiling_Violation : Boolean;
begin
pragma Debug
(Debug.Trace (Self_ID, "Protected_Entry_Call", 'P'));
if Runtime_Traces then
Send_Trace_Info (PO_Call, Entry_Index (E));
end if;
if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
Raise_Exception
(Storage_Error'Identity, "not enough ATC nesting levels");
end if;
Initialization.Defer_Abort (Self_ID);
Lock_Entries (Object, Ceiling_Violation);
if Ceiling_Violation then
Initialization.Undefer_Abort (Self_ID);
raise Program_Error;
end if;
Block.Self := Self_ID;
Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1;
pragma Debug
(Debug.Trace (Self_ID, "PEC: 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;
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 := STPO.Get_Priority (Self_ID);
Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
Entry_Call.Called_PO := To_Address (Object);
Entry_Call.Called_Task := null;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True);
Initially_Abortable := Entry_Call.State = Now_Abortable;
PO_Service_Entries (Self_ID, Object);
Unlock_Entries (Object);
if Entry_Call.State >= Done then
Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;
pragma Debug
(Debug.Trace (Self_ID, "PEC: exited to ATC level: " &
ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
Block.Enqueued := False;
Block.Cancelled := Entry_Call.State = Cancelled;
Initialization.Undefer_Abort (Self_ID);
Entry_Calls.Check_Exception (Self_ID, Entry_Call);
return;
else
null;
end if;
if Mode = Asynchronous_Call then
if not Initially_Abortable then
if Single_Lock then
STPO.Lock_RTS;
Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
STPO.Unlock_RTS;
else
Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
end if;
end if;
elsif Mode < Asynchronous_Call then
if Single_Lock then
STPO.Lock_RTS;
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock_RTS;
else
STPO.Write_Lock (Self_ID);
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock (Self_ID);
end if;
Block.Cancelled := Entry_Call.State = Cancelled;
else
pragma Assert (False);
null;
end if;
Initialization.Undefer_Abort (Self_ID);
Entry_Calls.Check_Exception (Self_ID, Entry_Call);
end Protected_Entry_Call;
function Protected_Entry_Caller
(Object : Protection_Entries'Class) return Task_ID is
begin
return Object.Call_In_Progress.Self;
end Protected_Entry_Caller;
procedure Requeue_Protected_Entry
(Object : Protection_Entries_Access;
New_Object : Protection_Entries_Access;
E : Protected_Entry_Index;
With_Abort : Boolean)
is
Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
begin
pragma Debug
(Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P'));
pragma Assert (STPO.Self.Deferral_Level > 0);
Entry_Call.E := Entry_Index (E);
Entry_Call.Called_PO := To_Address (New_Object);
Entry_Call.Called_Task := null;
Entry_Call.Requeue_With_Abort := With_Abort;
Object.Call_In_Progress := null;
end Requeue_Protected_Entry;
procedure Requeue_Task_To_Protected_Entry
(New_Object : Protection_Entries_Access;
E : Protected_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.Called_PO := To_Address (New_Object);
Entry_Call.Called_Task := null;
Entry_Call.E := Entry_Index (E);
Initialization.Undefer_Abort (Self_ID);
end Requeue_Task_To_Protected_Entry;
procedure Service_Entries (Object : Protection_Entries_Access) is
Self_ID : constant Task_ID := STPO.Self;
begin
PO_Service_Entries (Self_ID, Object);
end Service_Entries;
procedure Timed_Protected_Entry_Call
(Object : Protection_Entries_Access;
E : Protected_Entry_Index;
Uninterpreted_Data : System.Address;
Timeout : Duration;
Mode : Delay_Modes;
Entry_Call_Successful : out Boolean)
is
Self_Id : constant Task_ID := STPO.Self;
Entry_Call : Entry_Call_Link;
Ceiling_Violation : Boolean;
Yielded : Boolean;
begin
if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
Raise_Exception (Storage_Error'Identity,
"not enough ATC nesting levels");
end if;
if Runtime_Traces then
Send_Trace_Info (POT_Call, Entry_Index (E), Timeout);
end if;
Initialization.Defer_Abort (Self_Id);
Lock_Entries (Object, Ceiling_Violation);
if Ceiling_Violation then
Initialization.Undefer_Abort (Self_Id);
raise Program_Error;
end if;
Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
pragma Debug
(Debug.Trace (Self_Id, "TPEC: exited to 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 := 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 := STPO.Get_Priority (Self_Id);
Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
Entry_Call.Called_PO := To_Address (Object);
Entry_Call.Called_Task := null;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
PO_Do_Or_Queue (Self_Id, Object, Entry_Call, With_Abort => True);
PO_Service_Entries (Self_Id, Object);
Unlock_Entries (Object);
if Entry_Call.State >= Done then
Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
pragma Debug
(Debug.Trace (Self_Id, "TPEC: exited to ATC level: " &
ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
Entry_Call_Successful := Entry_Call.State = Done;
Initialization.Undefer_Abort (Self_Id);
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
return;
end if;
if Single_Lock then
STPO.Lock_RTS;
else
STPO.Write_Lock (Self_Id);
end if;
Entry_Calls.Wait_For_Completion_With_Timeout
(Entry_Call, Timeout, Mode, Yielded);
if Single_Lock then
STPO.Unlock_RTS;
else
STPO.Unlock (Self_Id);
end if;
Initialization.Undefer_Abort (Self_Id);
Entry_Call_Successful := Entry_Call.State = Done;
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
end Timed_Protected_Entry_Call;
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 Update_For_Queue_To_PO
(Entry_Call : Entry_Call_Link;
With_Abort : Boolean)
is
Old : Entry_Call_State := Entry_Call.State;
begin
pragma Assert (Old < Done);
Entry_Call.State := New_State (With_Abort, Entry_Call.State);
if Entry_Call.Mode = Asynchronous_Call then
if Old < Was_Abortable and then
Entry_Call.State = Now_Abortable
then
if Single_Lock then
STPO.Lock_RTS;
end if;
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);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
elsif Entry_Call.Mode = Conditional_Call then
pragma Assert (Entry_Call.State < Was_Abortable);
null;
end if;
end Update_For_Queue_To_PO;
end System.Tasking.Protected_Objects.Operations;