------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS --
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2016, 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 --
-- . --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains all extended primitives related to Protected_Objects
-- with entries.
-- The handling of protected objects with no entries is done in
-- System.Tasking.Protected_Objects, the simple routines for protected
-- objects with entries in System.Tasking.Protected_Objects.Entries.
-- The split between Entries and Operations is needed to break circular
-- dependencies inside the run time.
-- This package contains all primitives related to Protected_Objects.
-- Note: the compiler generates direct calls to this interface, via Rtsfind.
with System.Task_Primitives.Operations;
with System.Tasking.Entry_Calls;
with System.Tasking.Queuing;
with System.Tasking.Rendezvous;
with System.Tasking.Utilities;
with System.Tasking.Debug;
with System.Parameters;
with System.Traces.Tasking;
with System.Restrictions;
with System.Tasking.Initialization;
pragma Elaborate_All (System.Tasking.Initialization);
-- Insures that tasking is initialized if any protected objects are created
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.Restrictions;
use System.Restrictions.Rident;
use System.Traces;
use System.Traces.Tasking;
-----------------------
-- Local Subprograms --
-----------------------
procedure Update_For_Queue_To_PO
(Entry_Call : Entry_Call_Link;
With_Abort : Boolean);
pragma Inline (Update_For_Queue_To_PO);
-- Update the state of an existing entry call to reflect the fact that it
-- is being enqueued, based on whether the current queuing action is with
-- or without abort. Call this only while holding the PO's lock. It returns
-- with the PO's lock still held.
procedure Requeue_Call
(Self_Id : Task_Id;
Object : Protection_Entries_Access;
Entry_Call : Entry_Call_Link);
-- Handle requeue of Entry_Call.
-- In particular, queue the call if needed, or service it immediately
-- if possible.
---------------------------------
-- Cancel_Protected_Entry_Call --
---------------------------------
-- Compiler interface only (do not call from within the RTS)
-- This should have analogous effect to Cancel_Task_Entry_Call, setting
-- the value of Block.Cancelled instead of returning the parameter value
-- Cancelled.
-- The effect should be idempotent, since the call may already have been
-- dequeued.
-- Source code:
-- select r.e;
-- ...A...
-- then abort
-- ...B...
-- end select;
-- Expanded code:
-- declare
-- X : protected_entry_index := 1;
-- B80b : communication_block;
-- communication_blockIP (B80b);
-- begin
-- begin
-- A79b : label
-- A79b : declare
-- procedure _clean is
-- begin
-- if enqueued (B80b) then
-- cancel_protected_entry_call (B80b);
-- end if;
-- return;
-- end _clean;
-- begin
-- protected_entry_call (rTV!(r)._object'unchecked_access, X,
-- null_address, asynchronous_call, B80b, objectF => 0);
-- if enqueued (B80b) then
-- ...B...
-- end if;
-- at end
-- _clean;
-- end A79b;
-- exception
-- when _abort_signal =>
-- abort_undefer.all;
-- null;
-- end;
-- if not cancelled (B80b) then
-- x := ...A...
-- end if;
-- end;
-- If the entry call completes after we get into the abortable part,
-- Abort_Signal should be raised and ATC will take us to the at-end
-- handler, which will call _clean.
-- If the entry call returns with the call already completed, we can skip
-- this, and use the "if enqueued()" to go past the at-end handler, but we
-- will still call _clean.
-- If the abortable part completes before the entry call is Done, it will
-- call _clean.
-- If the entry call or the abortable part raises an exception,
-- we will still call _clean, but the value of Cancelled should not matter.
-- Whoever calls _clean first gets to decide whether the call
-- has been "cancelled".
-- Enqueued should be true if there is any chance that the call is still on
-- a queue. It seems to be safe to make it True if the call was Onqueue at
-- some point before return from Protected_Entry_Call.
-- Cancelled should be true iff the abortable part completed
-- and succeeded in cancelling the entry call before it completed.
-- ?????
-- The need for Enqueued is less obvious. The "if enqueued ()" tests are
-- not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call
-- must do the same test internally, with locking. The one that makes
-- cancellation conditional may be a useful heuristic since at least 1/2
-- the time the call should be off-queue by that point. The other one seems
-- totally useless, since Protected_Entry_Call must do the same check and
-- then possibly wait for the call to be abortable, internally.
-- We can check Call.State here without locking the caller's mutex,
-- since the call must be over after returning from Wait_For_Completion.
-- No other task can access the call record at this point.
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;
---------------
-- Cancelled --
---------------
function Cancelled (Block : Communication_Block) return Boolean is
begin
return Block.Cancelled;
end Cancelled;
-------------------------
-- Complete_Entry_Body --
-------------------------
procedure Complete_Entry_Body (Object : Protection_Entries_Access) is
begin
Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id);
end Complete_Entry_Body;
--------------
-- Enqueued --
--------------
function Enqueued (Block : Communication_Block) return Boolean is
begin
return Block.Enqueued;
end Enqueued;
-------------------------------------
-- Exceptional_Complete_Entry_Body --
-------------------------------------
procedure Exceptional_Complete_Entry_Body
(Object : Protection_Entries_Access;
Ex : Ada.Exceptions.Exception_Id)
is
procedure Transfer_Occurrence
(Target : Ada.Exceptions.Exception_Occurrence_Access;
Source : Ada.Exceptions.Exception_Occurrence);
pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
Self_Id : Task_Id;
begin
pragma Debug
(Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P'));
-- We must have abort deferred, since we are inside a protected
-- operation.
if Entry_Call /= null then
-- The call was not requeued
Entry_Call.Exception_To_Raise := Ex;
if Ex /= Ada.Exceptions.Null_Id then
-- An exception was raised and abort was deferred, so adjust
-- before propagating, otherwise the task will stay with deferral
-- enabled for its remaining life.
Self_Id := STPO.Self;
if not ZCX_By_Default then
Initialization.Undefer_Abort_Nestable (Self_Id);
end if;
Transfer_Occurrence
(Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access,
Self_Id.Common.Compiler_Data.Current_Excep);
end if;
-- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
-- PO_Service_Entries on return.
end if;
if Runtime_Traces then
-- ??? Entry_Call can be null
Send_Trace_Info (PO_Done, Entry_Call.Self);
end if;
end Exceptional_Complete_Entry_Body;
--------------------
-- PO_Do_Or_Queue --
--------------------
procedure PO_Do_Or_Queue
(Self_ID : Task_Id;
Object : Protection_Entries_Access;
Entry_Call : Entry_Call_Link)
is
E : constant Protected_Entry_Index :=
Protected_Entry_Index (Entry_Call.E);
Barrier_Value : Boolean;
begin
-- When the Action procedure for an entry body returns, it is either
-- completed (having called [Exceptional_]Complete_Entry_Body) or it
-- is queued, having executed a requeue statement.
Barrier_Value :=
Object.Entry_Bodies (
Object.Find_Body_Index (Object.Compiler_Info, E)).
Barrier (Object.Compiler_Info, E);
if Barrier_Value then
-- Not abortable while service is in progress
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
-- Body of current entry served call to completion
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
Requeue_Call (Self_ID, Object, Entry_Call);
end if;
elsif Entry_Call.Mode /= Conditional_Call
or else not Entry_Call.With_Abort
then
if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
and then Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
Queuing.Count_Waiting (Object.Entry_Queues (E))
then
-- This violates the Max_Entry_Queue_Length restriction, raise
-- Program_Error.
Entry_Call.Exception_To_Raise := Program_Error'Identity;
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
Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);
end if;
else
-- Conditional_Call and With_Abort
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Entry_Call.Self);
pragma Assert (Entry_Call.State /= Not_Yet_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;
------------------------
-- PO_Service_Entries --
------------------------
procedure PO_Service_Entries
(Self_ID : Task_Id;
Object : Entries.Protection_Entries_Access;
Unlock_Object : Boolean := True)
is
E : Protected_Entry_Index;
Caller : Task_Id;
Entry_Call : Entry_Call_Link;
begin
loop
Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call);
exit when Entry_Call = null;
E := Protected_Entry_Index (Entry_Call.E);
-- Not abortable while service is in progress
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
Requeue_Call (Self_ID, Object, Entry_Call);
exit when Entry_Call.State = Cancelled;
else
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;
end if;
end loop;
if Unlock_Object then
Unlock_Entries (Object);
end if;
end PO_Service_Entries;
---------------------
-- Protected_Count --
---------------------
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;
--------------------------
-- Protected_Entry_Call --
--------------------------
-- Compiler interface only (do not call from within the RTS)
-- select r.e;
-- ...A...
-- else
-- ...B...
-- end select;
-- declare
-- X : protected_entry_index := 1;
-- B85b : communication_block;
-- communication_blockIP (B85b);
-- begin
-- protected_entry_call (rTV!(r)._object'unchecked_access, X,
-- null_address, conditional_call, B85b, objectF => 0);
-- if cancelled (B85b) then
-- ...B...
-- else
-- ...A...
-- end if;
-- end;
-- See also Cancel_Protected_Entry_Call for code expansion of asynchronous
-- entry call.
-- The initial part of this procedure does not need to lock the calling
-- task's ATCB, up to the point where the call record first may be queued
-- (PO_Do_Or_Queue), since before that no other task will have access to
-- the record.
-- If this is a call made inside of an abort deferred region, the call
-- should be never abortable.
-- If the call was not queued abortably, we need to wait until it is before
-- proceeding with the abortable part.
-- There are some heuristics here, just to save time for frequently
-- occurring cases. For example, we check Initially_Abortable to try to
-- avoid calling the procedure Wait_Until_Abortable, since the normal case
-- for async. entry calls is to be queued abortably.
-- Another heuristic uses the Block.Enqueued to try to avoid calling
-- Cancel_Protected_Entry_Call if the call can be served immediately.
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 : constant 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 Storage_Error with "not enough ATC nesting levels";
end if;
-- If pragma Detect_Blocking is active then Program_Error must be
-- raised if this potentially blocking operation is called from a
-- protected action.
if Detect_Blocking
and then Self_ID.Common.Protected_Action_Nesting > 0
then
raise Program_Error with "potentially blocking operation";
end if;
-- Self_ID.Deferral_Level should be 0, except when called from Finalize,
-- where abort is already deferred.
Initialization.Defer_Abort_Nestable (Self_ID);
Lock_Entries_With_Status (Object, Ceiling_Violation);
if Ceiling_Violation then
-- Failed ceiling check
Initialization.Undefer_Abort_Nestable (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;
Entry_Call.State :=
(if Self_ID.Deferral_Level > 1
then Never_Abortable else Now_Abortable);
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;
Entry_Call.With_Abort := True;
PO_Do_Or_Queue (Self_ID, Object, Entry_Call);
Initially_Abortable := Entry_Call.State = Now_Abortable;
PO_Service_Entries (Self_ID, Object);
-- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
-- for completed or cancelled calls. (This is a heuristic, only.)
if Entry_Call.State >= Done then
-- Once State >= Done it will not change any more
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Self_ID);
Utilities.Exit_One_ATC_Level (Self_ID);
STPO.Unlock (Self_ID);
if Single_Lock then
STPO.Unlock_RTS;
end if;
Block.Enqueued := False;
Block.Cancelled := Entry_Call.State = Cancelled;
Initialization.Undefer_Abort_Nestable (Self_ID);
Entry_Calls.Check_Exception (Self_ID, Entry_Call);
return;
else
-- In this case we cannot conclude anything, since State can change
-- concurrently.
null;
end if;
-- Now for the general case
if Mode = Asynchronous_Call then
-- Try to avoid an expensive call
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;
else
case Mode is
when Simple_Call | Conditional_Call =>
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;
when Asynchronous_Call | Timed_Call =>
pragma Assert (False);
null;
end case;
end if;
Initialization.Undefer_Abort_Nestable (Self_ID);
Entry_Calls.Check_Exception (Self_ID, Entry_Call);
end Protected_Entry_Call;
------------------
-- Requeue_Call --
------------------
procedure Requeue_Call
(Self_Id : Task_Id;
Object : Protection_Entries_Access;
Entry_Call : Entry_Call_Link)
is
New_Object : Protection_Entries_Access;
Ceiling_Violation : Boolean;
Result : Boolean;
E : Protected_Entry_Index;
begin
New_Object := To_Protection (Entry_Call.Called_PO);
if New_Object = null then
-- Call is to be requeued to a task entry
if Single_Lock then
STPO.Lock_RTS;
end if;
Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call);
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
-- Call should be requeued to a PO
if Object /= New_Object then
-- Requeue is to different PO
Lock_Entries_With_Status (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);
PO_Service_Entries (Self_Id, New_Object);
end if;
else
-- Requeue is to same protected object
-- ??? Try to compensate apparent failure of the scheduler on some
-- OS (e.g VxWorks) to give higher priority tasks a chance to run
-- (see CXD6002).
STPO.Yield (Do_Yield => False);
if Entry_Call.With_Abort
and then Entry_Call.Cancellation_Attempted
then
-- If this is a requeue with abort and someone tried to cancel
-- this call, cancel it at this point.
Entry_Call.State := Cancelled;
return;
end if;
if not Entry_Call.With_Abort
or else Entry_Call.Mode /= Conditional_Call
then
E := Protected_Entry_Index (Entry_Call.E);
if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
and then
Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
Queuing.Count_Waiting (Object.Entry_Queues (E))
then
-- This violates the Max_Entry_Queue_Length restriction,
-- raise Program_Error.
Entry_Call.Exception_To_Raise := Program_Error'Identity;
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
Queuing.Enqueue
(New_Object.Entry_Queues (E), Entry_Call);
Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);
end if;
else
PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call);
end if;
end if;
end if;
end Requeue_Call;
----------------------------
-- Protected_Entry_Caller --
----------------------------
function Protected_Entry_Caller
(Object : Protection_Entries'Class) return Task_Id is
begin
return Object.Call_In_Progress.Self;
end Protected_Entry_Caller;
-----------------------------
-- Requeue_Protected_Entry --
-----------------------------
-- Compiler interface only (do not call from within the RTS)
-- entry e when b is
-- begin
-- b := false;
-- ...A...
-- requeue e2;
-- end e;
-- procedure rPT__E10b (O : address; P : address; E :
-- protected_entry_index) is
-- type rTVP is access rTV;
-- freeze rTVP []
-- _object : rTVP := rTVP!(O);
-- begin
-- declare
-- rR : protection renames _object._object;
-- vP : integer renames _object.v;
-- bP : boolean renames _object.b;
-- begin
-- b := false;
-- ...A...
-- requeue_protected_entry (rR'unchecked_access, rR'
-- unchecked_access, 2, false, objectF => 0, new_objectF =>
-- 0);
-- return;
-- end;
-- complete_entry_body (_object._object'unchecked_access, objectF =>
-- 0);
-- return;
-- exception
-- when others =>
-- abort_undefer.all;
-- exceptional_complete_entry_body (_object._object'
-- unchecked_access, current_exception, objectF => 0);
-- return;
-- end rPT__E10b;
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.With_Abort := With_Abort;
Object.Call_In_Progress := null;
end Requeue_Protected_Entry;
-------------------------------------
-- Requeue_Task_To_Protected_Entry --
-------------------------------------
-- Compiler interface only (do not call from within the RTS)
-- accept e1 do
-- ...A...
-- requeue r.e2;
-- end e1;
-- A79b : address;
-- L78b : label
-- begin
-- accept_call (1, A79b);
-- ...A...
-- requeue_task_to_protected_entry (rTV!(r)._object'
-- unchecked_access, 2, false, new_objectF => 0);
-- goto L78b;
-- <>
-- complete_rendezvous;
-- exception
-- when all others =>
-- exceptional_complete_rendezvous (get_gnat_exception);
-- end;
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);
-- We do not need to lock Self_ID here since the call is not abortable
-- at this point, and therefore, the caller cannot cancel the call.
Entry_Call.Needs_Requeue := True;
Entry_Call.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;
---------------------
-- Service_Entries --
---------------------
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;
--------------------------------
-- Timed_Protected_Entry_Call --
--------------------------------
-- Compiler interface only (do not call from within the RTS)
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;
pragma Unreferenced (Yielded);
begin
if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
raise Storage_Error with "not enough ATC nesting levels";
end if;
-- If pragma Detect_Blocking is active then Program_Error must be
-- raised if this potentially blocking operation is called from a
-- protected action.
if Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
raise Program_Error with "potentially blocking operation";
end if;
if Runtime_Traces then
Send_Trace_Info (POT_Call, Entry_Index (E), Timeout);
end if;
Initialization.Defer_Abort_Nestable (Self_Id);
Lock_Entries_With_Status (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;
Entry_Call.State :=
(if Self_Id.Deferral_Level > 1
then Never_Abortable
else Now_Abortable);
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;
Entry_Call.With_Abort := True;
PO_Do_Or_Queue (Self_Id, Object, Entry_Call);
PO_Service_Entries (Self_Id, Object);
if Single_Lock then
STPO.Lock_RTS;
else
STPO.Write_Lock (Self_Id);
end if;
-- Try to avoid waiting for completed or cancelled calls
if Entry_Call.State >= Done then
Utilities.Exit_One_ATC_Level (Self_Id);
if Single_Lock then
STPO.Unlock_RTS;
else
STPO.Unlock (Self_Id);
end if;
Entry_Call_Successful := Entry_Call.State = Done;
Initialization.Undefer_Abort_Nestable (Self_Id);
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
return;
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;
-- ??? Do we need to yield in case Yielded is False
Initialization.Undefer_Abort_Nestable (Self_Id);
Entry_Call_Successful := Entry_Call.State = Done;
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
end Timed_Protected_Entry_Call;
----------------------------
-- Update_For_Queue_To_PO --
----------------------------
-- Update the state of an existing entry call, based on
-- whether the current queuing action is with or without abort.
-- Call this only while holding the server's lock.
-- It returns with the server's lock released.
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 : constant 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;