File : s-tasren.adb
------------------------------------------------------------------------------
-- --
-- GNU ADA 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 --
-- --
-- $Revision: 1.97 $
-- --
-- Copyright (C) 1991-1999, Florida State University --
-- --
-- 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 2, or (at your option) any later ver- --
-- sion. GNARL 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNARL; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions;
-- Used for Exception_ID
-- Null_Id
-- Save_Occurrence
-- Raise_Exception
with System.Task_Primitives.Operations;
-- used for Get_Priority
-- Set_Priority
-- Write_Lock
-- Unlock
-- Sleep
-- Wakeup
-- Timed_Sleep
with System.Tasking.Entry_Calls;
-- Used for Wait_For_Completion
-- Wait_For_Completion_With_Timeout
-- Wait_Until_Abortable
with System.Tasking.Initialization;
-- used for Defer_Abort
-- Undefer_Abort
-- Poll_Base_Priority_Change
with System.Tasking.Queuing;
-- used for Enqueue
-- Dequeue_Head
-- Select_Task_Entry_Call
-- Count_Waiting
with System.Tasking.Utilities;
-- used for Check_Exception
-- Make_Passive
-- Wakeup_Entry_Caller
with System.Tasking.Protected_Objects.Operations;
-- used for PO_Do_Or_Queue
-- PO_Service_Entries
-- Lock_Entries
-- Unlock_Entries
with System.Tasking.Debug;
-- used for Trace
package body System.Tasking.Rendezvous is
package STPO renames System.Task_Primitives.Operations;
package POO renames System.Tasking.Protected_Objects.Operations;
package POE renames System.Tasking.Protected_Objects.Entries;
use System.Task_Primitives;
use System.Task_Primitives.Operations;
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);
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 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.
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
-- privious caller and adjust the priority. Also we need to make
-- this call not Abortable (Cancellable) since the rendezvous has
-- already been started.
function Is_Entry_Open (T : Task_ID; E : Task_Entry_Index) return Boolean;
pragma Inline (Is_Entry_Open);
-- Call this only with abort deferred and holding lock of T.
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 abortion.
-- Make sure Self_Id is locked before calling this routine.
--------------------
-- Boost_Priority --
--------------------
-- Call this only with abort deferred and holding lock of Acceptor.
procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_ID) is
Caller : Task_ID := Call.Self;
Caller_Prio : System.Any_Priority := Get_Priority (Caller);
Acceptor_Prio : 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;
----------------------
-- Task_Do_Or_Queue --
----------------------
-- Call this only with abort deferred and holding no locks.
-- May propagate an exception, including Abort_Signal & Tasking_Error.
-- ?????
-- See Check_Callable. Check all call contexts to verify
-- it is OK to raise an exception.
-- Find out whether Entry_Call can be accepted immediately.
-- If the Acceptor is not callable, raise Tasking_Error.
-- 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.
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.Parent;
Parent_Locked : Boolean := False;
Null_Body : Boolean;
begin
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.
-- We can't lock Acceptor.Parent while holding Acceptor,
-- so lock it in advance if we expect to need to lock it.
-- ?????
-- Is there some better solution?
if Acceptor.Terminate_Alternative then
STPO.Write_Lock (Parent);
Parent_Locked := True;
end if;
STPO.Write_Lock (Acceptor);
-- If the acceptor is not callable, abort the call
-- and raise Tasking_Error. The call is not aborted
-- for an asynchronous call, since Cancel_Task_Entry_Call
-- will do the cancelation in that case.
-- ????? .....
-- Does the above still make sense?
if not Acceptor.Callable then
STPO.Unlock (Acceptor);
if Parent_Locked then
STPO.Unlock (Acceptor.Parent);
end if;
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.State = Master_Completion_Sleep and then
Acceptor.Master_of_Task = Parent.Master_Within
then
Parent.Wait_Count := Parent.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);
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);
-- For terminate_alternative, acceptor may not be
-- asleep yet, so we skip the wakeup
if Acceptor.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;
-- 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 Entry_Call.Mode /= Conditional_Call
or else not With_Abort
then
-- 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 (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
-- Asynchronous_Call or Conditional_Call
Entry_Call.Self /= Self_ID
then
-- Because of ATCB lock ordering rule
STPO.Write_Lock (Entry_Call.Self);
if Entry_Call.Self.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;
else
-- Conditional_Call and With_Abort
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;
------------------------------------
-- Setup_For_Rendezvous_With_Body --
------------------------------------
-- Call this only with abort deferred and holding lock of Acceptor.
procedure Setup_For_Rendezvous_With_Body
(Entry_Call : Entry_Call_Link;
Acceptor : Task_ID)
is
begin
Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
Acceptor.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;
----------------------
-- Call_Synchronous --
----------------------
-- Compiler interface.
-- Also called from inside Call_Simple and Task_Entry_Call.
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 this is a call made inside of an abort deferred region,
-- the call should be never abortable.
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;
-- Note: the caller will undefer abortion on return (see WARNING above)
if not Task_Do_Or_Queue
(Self_Id, Entry_Call, With_Abort => True)
then
Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
Initialization.Undefer_Abort (Self_Id);
pragma Debug
(Debug.Trace (Self_Id, "CS: exited to ATC level: " &
ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
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 (Self_Id, Entry_Call);
pragma Debug
(Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
Rendezvous_Successful := Entry_Call.State = Done;
STPO.Unlock (Self_Id);
Local_Undefer_Abort (Self_Id);
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
end Call_Synchronous;
-----------------
-- Call_Simple --
-----------------
-- Compiler interface only. Do not call from within the RTS.
procedure Call_Simple
(Acceptor : Task_ID;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address)
is
Rendezvous_Successful : Boolean;
begin
Call_Synchronous
(Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
end Call_Simple;
----------------------------
-- Cancel_Task_Entry_Call --
----------------------------
-- Compiler interface only. Do not call from within the RTS.
-- Call only with abort deferred.
procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
begin
Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled);
end Cancel_Task_Entry_Call;
------------------------
-- Requeue_Task_Entry --
------------------------
-- Compiler interface only. Do not call from within the RTS.
-- The code generation for task entry requeues is different from that
-- for protected entry requeues. There is a "goto" that skips around
-- the call to Complete_Rendezous, so that Requeue_Task_Entry must also
-- do the work of Complete_Rendezvous. The difference is that it does
-- not report that the call's State = Done.
-- accept e1 do
-- ...A...
-- requeue e2;
-- ...B...
-- end e1;
-- A62b : address;
-- L61b : label
-- begin
-- accept_call (1, A62b);
-- ...A...
-- requeue_task_entry (tTV!(t)._task_id, 2, false);
-- goto L61b;
-- ...B...
-- complete_rendezvous;
-- <<L61b>>
-- exception
-- when others =>
-- exceptional_complete_rendezvous (current_exception);
-- end;
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.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;
-------------------------------------
-- Requeue_Protected_To_Task_Entry --
-------------------------------------
-- Compiler interface only. Do not call from within the RTS.
-- entry e2 when b is
-- begin
-- b := false;
-- ...A...
-- requeue t.e2;
-- end e2;
-- procedure rPT__E14b (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_to_task_entry (rR'unchecked_access, tTV!(t).
-- _task_id, 2, false);
-- 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__E14b;
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;
---------------------
-- 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 Mode = Simple_Call or else Mode = Conditional_Call then
Call_Synchronous
(Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
else
-- This is an asynchronous call
-- Abortion must already be deferred by the compiler-generated
-- code. Without this, an abortion 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;
if not Task_Do_Or_Queue
(Self_Id, Entry_Call, With_Abort => True)
then
Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
pragma Debug
(Debug.Trace (Self_Id, "TEC: exited to ATC level: " &
ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
Initialization.Undefer_Abort (Self_Id);
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;
-- Note: following assignment needs to be atomic.
Rendezvous_Successful := Entry_Call.State = Done;
end if;
end Task_Entry_Call;
---------------------------
-- Timed_Task_Entry_Call --
---------------------------
-- Compiler interface only. Do not call from within the RTS.
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;
begin
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'));
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.
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;
-- Note: the caller will undefer abortion on return (see WARNING above)
if not Task_Do_Or_Queue
(Self_Id, Entry_Call, With_Abort => True)
then
Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
pragma Debug
(Debug.Trace (Self_Id, "TTEC: exited to ATC level: " &
ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
Initialization.Undefer_Abort (Self_Id);
raise Tasking_Error;
end if;
Entry_Calls.Wait_For_Completion_With_Timeout
(Self_Id, Entry_Call, Timeout, Mode);
Rendezvous_Successful := Entry_Call.State = Done;
Initialization.Undefer_Abort (Self_Id);
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
end Timed_Task_Entry_Call;
-----------------
-- Accept_Call --
-----------------
-- Compiler interface only. Do not call from within the RTS.
-- source:
-- accept E do ...A... end E;
-- expansion:
-- A27b : address;
-- L26b : label
-- begin
-- accept_call (1, A27b);
-- ...A...
-- complete_rendezvous;
-- <<L26b>>
-- exception
-- when all others =>
-- exceptional_complete_rendezvous (get_gnat_exception);
-- end;
-- The handler for Abort_Signal (*all* others) is to handle the case when
-- the acceptor is aborted between Accept_Call and the corresponding
-- Complete_Rendezvous call. We need to wake up the caller in this case.
-- See also Selective_Wait
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);
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);
Initialization.Undefer_Abort (Self_Id);
-- Should never get here ???
pragma Assert (False);
raise Standard'Abort_Signal;
end if;
-- If someone completed this task, this task should not try to
-- access its pending entry calls or queues in this case, as they
-- are being emptied. Wait for abortion to kill us.
-- ?????
-- Recheck the correctness of the above, now that we have made
-- changes. The logic above seems to be based on the assumption
-- that one task can safely clean up another's in-service accepts.
-- ?????
-- Why do we need to block here in this case?
-- Why not just return and let Undefer_Abort do its work?
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
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.Pending_ATC_Level >= Self_Id.ATC_Nesting_Level then
Caller := Self_Id.Call.Self;
Uninterpreted_Data :=
Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
end if;
-- If this task has been aborted, skip the Uninterpreted_Data load
-- (Caller will not be reliable) and fall through to
-- Undefer_Abort which will allow the task to be killed.
-- ?????
-- Perhaps we could do the code anyway, if it has no harm, in order
-- to get better performance for the normal case.
end if;
-- Self_Id.Call should already be updated by the Caller
-- On return, we will start the rendezvous.
STPO.Unlock (Self_Id);
Initialization.Undefer_Abort (Self_Id);
end Accept_Call;
--------------------
-- Accept_Trivial --
--------------------
-- Compiler interface only. Do not call from within the RTS.
-- This should only be called when there is no accept body,
-- or the except body is empty.
-- source:
-- accept E;
-- expansion:
-- accept_trivial (1);
-- The compiler is also able to recognize the following and
-- translate it the same way.
-- accept E do null; end E;
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);
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);
Initialization.Undefer_Abort_Nestable (Self_Id);
-- Should never get here ???
pragma Assert (False);
raise Standard'Abort_Signal;
end if;
-- If someone completed this task, this task should not try to
-- access its pending entry calls or queues in this case, as they
-- are being emptied. Wait for abortion to kill us.
-- ?????
-- Recheck the correctness of the above, now that we have made
-- changes.
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;
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);
else -- found caller already waiting
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;
Initialization.Undefer_Abort_Nestable (Self_Id);
end Accept_Trivial;
-------------------------------------
-- Exceptional_Complete_Rendezvous --
-------------------------------------
-- Compiler interface.
-- Also called from Complete_Rendezvous.
-- ?????
-- Consider phasing out Complete_Rendezvous in favor
-- of direct call to this with Ada.Exceptions.Null_ID.
-- See code expansion examples for Accept_Call and Selective_Wait.
-- ?????
-- If we don't change the interface, consider instead
-- putting an explicit re-raise after this call, in
-- the generated code. That way we could eliminate the
-- code here that reraises the exception.
-- 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.
procedure Exceptional_Complete_Rendezvous
(Ex : Ada.Exceptions.Exception_Id)
is
Self_Id : constant Task_ID := STPO.Self;
Entry_Call : Entry_Call_Link := Self_Id.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_Raise (X : Ada.Exceptions.Exception_Id);
pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
use type STPE.Protection_Entries_Access;
begin
pragma Debug
(Debug.Trace (Self_Id, "Exceptional_Complete_Rendezvous", 'R'));
if Ex = Ada.Exceptions.Null_Id then
-- The call came from normal end-of-rendezvous,
-- so abort is not yet deferred.
Initialization.Defer_Abort_Nestable (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
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;
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.Call := Entry_Call.Acceptor_Prev_Call;
if Entry_Call.Called_Task /= null then
-- Requeue to another task entry
if not Task_Do_Or_Queue
(Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort)
then
Initialization.Undefer_Abort (Self_Id);
raise Tasking_Error;
end if;
else
-- Requeue to a protected entry
Called_PO := POE.To_Protection (Entry_Call.Called_PO);
STPO.Write_Lock (Called_PO.L'Access, 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;
STPO.Write_Lock (Caller);
Initialization.Wakeup_Entry_Caller
(Self_Id, Entry_Call, Done);
STPO.Unlock (Caller);
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);
STPE.Unlock_Entries (Called_PO);
end if;
end if;
Entry_Calls.Reset_Priority (Entry_Call.Acceptor_Prev_Priority,
Self_Id);
else
-- The call does not need to be requeued.
Self_Id.Call := Entry_Call.Acceptor_Prev_Call;
Entry_Call.Exception_To_Raise := Ex;
STPO.Write_Lock (Caller);
-- Done with Caller locked to make sure that Wakeup is not lost.
if Ex /= Ada.Exceptions.Null_Id then
Ada.Exceptions.Save_Occurrence
(Caller.Compiler_Data.Current_Excep,
Self_Id.Compiler_Data.Current_Excep);
end if;
Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
STPO.Unlock (Caller);
Entry_Calls.Reset_Priority (Entry_Call.Acceptor_Prev_Priority,
Self_Id);
end if;
end if;
Initialization.Undefer_Abort (Self_Id);
if Exception_To_Raise /= Ada.Exceptions.Null_Id then
Internal_Raise (Exception_To_Raise);
end if;
-- ?????
-- 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;
-------------------------
-- Complete_Rendezvous --
-------------------------
-- See comments for Exceptional_Complete_Rendezvous.
procedure Complete_Rendezvous is
begin
Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id);
end Complete_Rendezvous;
--------------------
-- Selective_Wait --
--------------------
-- Compiler interface only. Do not call from within the RTS.
-- See comments on Accept_Call.
-- source code:
-- select accept e1 do
-- ...A...
-- end e1;
-- ...B...
-- or accept e2;
-- ...C...
-- end select;
-- expansion:
-- A32b : address;
-- declare
-- null;
-- if accept_alternative'size * 2 >= 16#8000_0000# then
-- raise storage_error;
-- end if;
-- A37b : T36b;
-- A37b (1) := (null_body => false, s => 1);
-- A37b (2) := (null_body => true, s => 2);
-- if accept_alternative'size * 2 >= 16#8000_0000# then
-- raise storage_error;
-- end if;
-- S0 : aliased T36b := accept_list'A37b;
-- J1 : select_index := 0;
-- L3 : label
-- L1 : label
-- L2 : label
-- procedure e1A is
-- begin
-- abort_undefer.all;
-- L31b : label
-- ...A...
-- <<L31b>>
-- complete_rendezvous;
-- exception
-- when all others =>
-- exceptional_complete_rendezvous (get_gnat_exception);
-- end e1A;
-- begin
-- selective_wait (S0'unchecked_access, simple_mode, A32b, J1);
-- case J1 is
-- when 0 =>
-- goto L3;
-- when 1 =>
-- e1A;
-- goto L1;
-- when 2 =>
-- goto L2;
-- when others =>
-- goto L3;
-- end case;
-- <<L1>>
-- ...B...
-- goto L3;
-- <<L2>>
-- ...C...
-- goto L3;
-- <<L3>>
-- end;
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);
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);
-- ??? In some cases abort is deferred more than once. Need to figure
-- out why.
Self_Id.Deferral_Level := 1;
Initialization.Undefer_Abort (Self_Id);
-- Should never get here ???
pragma Assert (False);
raise Standard'Abort_Signal;
end if;
-- If someone completed this task, this task should not try to
-- access its pending entry calls or queues in this case, as they
-- are being emptied. Wait for abortion to kill us.
-- ?????
-- Recheck the correctness of the above, now that we have made
-- changes.
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;
-- ??????
-- Recheck the logic above against the ARM.
-- Handle the select according to the disposition selected above.
case Treatment is
when Accept_Alternative_Selected =>
-- Ready to rendezvous
Uninterpreted_Data := Self_Id.Call.Uninterpreted_Data;
-- In this case the accept body is not Null_Body. Defer abortion
-- until it gets into the accept body.
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.
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'));
Wait_For_Call (Self_Id);
pragma Assert (Self_Id.Open_Accepts = null);
-- Self_Id.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 abortion.
-- 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.Call /= null and then
not Open_Accepts (Self_Id.Chosen_Index).Null_Body
then
Uninterpreted_Data := Self_Id.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 Else_Selected =>
pragma Assert (Self_Id.Open_Accepts = null);
STPO.Unlock (Self_Id);
when Terminate_Selected =>
-- Terminate alternative is open
Self_Id.Open_Accepts := Open_Accepts;
Self_Id.State := Acceptor_Sleep;
STPO.Unlock (Self_Id);
-- ?????
-- We need to check if a signal is pending on an open interrupt
-- entry. Otherwise this task would become potentially terminatable
-- and, if none of the siblings are active
-- any more, the task could not wake up any more, even though a
-- signal might be pending on an open interrupt entry.
-- -------------
-- This comment paragraph does not make sense. Is it obsolete?
-- There was no code here to check for pending signals.
-- Notify ancestors that this task is on a terminate alternative.
Utilities.Make_Passive (Self_Id, Task_Completed => False);
-- Wait for normal entry call or termination
pragma Assert (Self_Id.ATC_Nesting_Level = 1);
STPO.Write_Lock (Self_Id);
loop
Initialization.Poll_Base_Priority_Change (Self_Id);
exit when Self_Id.Open_Accepts = null;
Sleep (Self_Id, Acceptor_Sleep);
end loop;
Self_Id.State := Runnable;
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);
-- Trust that it is OK to fall through.
null;
else
-- Self_Id.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.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
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.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.State := Runnable;
STPO.Unlock (Self_Id);
else
STPO.Unlock (Self_Id);
Initialization.Undefer_Abort (Self_Id);
Ada.Exceptions.Raise_Exception (Program_Error'Identity,
"Entry call not a delay mode");
end if;
end case;
-- Caller has been chosen.
-- Self_Id.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;
--------------------------
-- Timed_Selective_Wait --
--------------------------
-- Compiler interface only. Do not call from within the RTS.
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 := False;
begin
pragma Assert (Select_Mode = Delay_Mode);
Initialization.Defer_Abort (Self_Id);
-- If we are aborted here, the effect will be pending
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);
Initialization.Undefer_Abort (Self_Id);
-- Should never get here ???
pragma Assert (False);
raise Standard'Abort_Signal;
end if;
-- If someone completed this task, this task should not try to
-- access its pending entry calls or queues in this case, as they
-- are being emptied. Wait for abortion to kill us.
-- ?????
-- Recheck the correctness of the above, now that we have made
-- changes.
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 abortion
-- until it gets into the accept body.
Uninterpreted_Data := Self_Id.Call.Uninterpreted_Data;
Initialization.Defer_Abort (Self_Id);
STPO.Unlock (Self_Id);
when Accept_Alternative_Completed =>
-- Rendezvous is over
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.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
STPO.Timed_Sleep (Self_Id, Timeout, Mode,
Acceptor_Sleep, Timedout, Yielded);
end if;
if Timedout then
Self_Id.Open_Accepts := null;
end if;
end loop;
Self_Id.State := Runnable;
-- Self_Id.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 abortion.
-- 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.Call /= null and then
not Open_Accepts (Self_Id.Chosen_Index).Null_Body
then
Uninterpreted_Data := Self_Id.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);
if not Yielded then
Yield;
end if;
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
-- (Abortion, Priority change)
-- 3) Spurious wakeup
Self_Id.Open_Accepts := null;
Self_Id.State := Acceptor_Sleep;
Initialization.Poll_Base_Priority_Change (Self_Id);
STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
Timedout, Yielded);
Self_Id.State := Runnable;
STPO.Unlock (Self_Id);
if not Yielded then
Yield;
end if;
when others =>
-- Should never get here ???
pragma Assert (False);
null;
end case;
-- Caller has been chosen
-- Self_Id.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;
----------------
-- Task_Count --
----------------
-- Compiler interface only. Do not call from within the RTS.
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);
STPO.Write_Lock (Self_Id);
Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
STPO.Unlock (Self_Id);
Initialization.Undefer_Abort (Self_Id);
return Return_Count;
end Task_Count;
--------------
-- Callable --
--------------
-- Compiler interface.
-- Do not call from within the RTS,
-- except for body of Ada.Task_Identification.
function Callable (T : Task_ID) return Boolean is
Result : Boolean;
Self_Id : constant Task_ID := STPO.Self;
begin
Initialization.Defer_Abort (Self_Id);
STPO.Write_Lock (T);
Result := T.Callable;
STPO.Unlock (T);
Initialization.Undefer_Abort (Self_Id);
return Result;
end Callable;
-------------------
-- Is_Entry_Open --
-------------------
-- Call this only with abort deferred and holding lock of T.
function Is_Entry_Open (T : Task_ID; E : Task_Entry_Index) return Boolean is
begin
pragma Assert (T.Open_Accepts /= null);
if T.Open_Accepts /= null then
for J in T.Open_Accepts'Range loop
pragma Assert (J > 0);
if E = T.Open_Accepts (J).S then
return True;
end if;
end loop;
end if;
return False;
end Is_Entry_Open;
-----------------------
-- Task_Entry_Caller --
-----------------------
-- Compiler interface only.
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.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;
-------------------
-- Wait_For_Call --
-------------------
-- Call this only with abort deferred and holding lock of Self_Id.
-- Wait for normal call and a pending action.
procedure Wait_For_Call (Self_Id : Task_ID) is
begin
Self_Id.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.State := Runnable;
end Wait_For_Call;
end System.Tasking.Rendezvous;