------------------------------------------------------------------------------
-- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K I N G . R E N D E Z V O U S --
-- --
-- B o d y --
-- --
--- $Revision: 1.101 $
--- --
--- Copyright (C) 1991-2001, Florida State University --
+-- Copyright (C) 1992-2007, 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- --
-- 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. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, 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, --
-- 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). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-with Ada.Exceptions;
--- Used for Exception_ID
--- Null_Id
--- Save_Occurrence
--- Raise_Exception
-
with System.Task_Primitives.Operations;
-- used for Get_Priority
-- Set_Priority
with System.Tasking.Initialization;
-- used for Defer_Abort
-- Undefer_Abort
--- Poll_Base_Priority_Change
+-- Do_Pending_Action
with System.Tasking.Queuing;
-- used for Enqueue
-- used for Check_Exception
-- Make_Passive
-- Wakeup_Entry_Caller
+-- Exit_One_ATC_Level
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
+with System.Restrictions;
+-- used for Abort_Allowed
+
+with System.Parameters;
+-- used for Single_Lock
+-- Runtime_Traces
+
+with System.Traces.Tasking;
+-- used for Send_Trace_Info
+
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;
+ package POO renames Protected_Objects.Operations;
+ package POE renames Protected_Objects.Entries;
- use System.Task_Primitives;
- use System.Task_Primitives.Operations;
+ use Parameters;
+ use Task_Primitives.Operations;
+ use System.Traces;
+ use System.Traces.Tasking;
type Select_Treatment is (
Accept_Alternative_Selected, -- alternative with non-null body
Accept_Alternative_Open,
No_Alternative_Open);
+ ----------------
+ -- Local Data --
+ ----------------
+
Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
(Simple_Mode => No_Alternative_Open,
Else_Mode => Else_Selected,
-- Local Subprograms --
-----------------------
- procedure Local_Defer_Abort (Self_Id : Task_ID) renames
+ procedure Local_Defer_Abort (Self_Id : Task_Id) renames
System.Tasking.Initialization.Defer_Abort_Nestable;
- procedure Local_Undefer_Abort (Self_Id : Task_ID) renames
+ procedure Local_Undefer_Abort (Self_Id : Task_Id) renames
System.Tasking.Initialization.Undefer_Abort_Nestable;
-- Florist defers abort around critical sections that
-- 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
+ -- 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);
+ 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.
+ -- Call this only with abort deferred and holding lock of Acceptor
procedure Call_Synchronous
- (Acceptor : Task_ID;
+ (Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address;
Mode : Call_Modes;
Rendezvous_Successful : out Boolean);
pragma Inline (Call_Synchronous);
-- This call is used to make a simple or conditional entry call.
+ -- Called from Call_Simple and Task_Entry_Call.
procedure Setup_For_Rendezvous_With_Body
(Entry_Call : Entry_Call_Link;
- Acceptor : Task_ID);
+ 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
+ -- previous 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);
+ 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.
+ -- waiting for a call from the caller or waiting for an abort.
-- Make sure Self_Id is locked before calling this routine.
-----------------
-- 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;
+ 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_Action);
STPO.Unlock (Self_Id);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
Initialization.Undefer_Abort (Self_Id);
-- Should never get here ???
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
-- Wait for normal call
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
+ end if;
+
pragma Debug
(Debug.Trace (Self_Id, "Accept_Call: wait", 'R'));
Wait_For_Call (Self_Id);
pragma Assert (Self_Id.Open_Accepts = null);
- if Self_Id.Pending_ATC_Level >= Self_Id.ATC_Nesting_Level then
+ if Self_Id.Common.Call /= null then
Caller := Self_Id.Common.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.
+ else
+ -- Case of an aborted task
+ Uninterpreted_Data := System.Null_Address;
+ end if;
end if;
-- Self_Id.Common.Call should already be updated by the Caller
-- On return, we will start the rendezvous.
STPO.Unlock (Self_Id);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
Initialization.Undefer_Abort (Self_Id);
+
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E));
+ end if;
end Accept_Call;
--------------------
-- Accept_Trivial --
--------------------
- -- 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;
+ 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_Action);
STPO.Unlock (Self_Id);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
Initialization.Undefer_Abort_Nestable (Self_Id);
-- Should never get here ???
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;
+ 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'));
STPO.Unlock (Self_Id);
else -- found caller already waiting
-
pragma Assert (Entry_Call.State < Done);
STPO.Unlock (Self_Id);
STPO.Unlock (Caller);
end if;
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (M_Accept_Complete);
+
+ -- Fake one, since there is (???) no way
+ -- to know that the rendezvous is over
+
+ Send_Trace_Info (M_RDV_Complete);
+ end if;
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
Initialization.Undefer_Abort_Nestable (Self_Id);
end Accept_Trivial;
-- Boost_Priority --
--------------------
- -- 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);
+ 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_Simple --
-----------------
- -- Compiler interface only. Do not call from within the RTS.
-
procedure Call_Simple
- (Acceptor : Task_ID;
+ (Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address)
is
Rendezvous_Successful : Boolean;
+
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then STPO.Self.Common.Protected_Action_Nesting > 0
+ then
+ 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;
-- Call_Synchronous --
----------------------
- -- Compiler interface.
- -- Also called from inside Call_Simple and Task_Entry_Call.
-
procedure Call_Synchronous
- (Acceptor : Task_ID;
+ (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;
+ Self_Id : constant Task_Id := STPO.Self;
Level : ATC_Level;
Entry_Call : Entry_Call_Link;
Entry_Call.Mode := Mode;
Entry_Call.Cancellation_Attempted := False;
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
+ end if;
+
-- If this is a call made inside of an abort deferred region,
-- the call should be never abortable.
Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
Entry_Call.Called_Task := Acceptor;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
+ Entry_Call.With_Abort := True;
- -- Note: the caller will undefer abortion on return (see WARNING above)
+ -- Note: the caller will undefer abort 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'));
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
+ STPO.Write_Lock (Self_Id);
+ Utilities.Exit_One_ATC_Level (Self_Id);
+ STPO.Unlock (Self_Id);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (E_Missed, Acceptor);
+ end if;
+
+ Local_Undefer_Abort (Self_Id);
raise Tasking_Error;
end if;
STPO.Write_Lock (Self_Id);
pragma Debug
(Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R'));
- Entry_Calls.Wait_For_Completion (Self_Id, Entry_Call);
+ Entry_Calls.Wait_For_Completion (Entry_Call);
pragma Debug
(Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
Rendezvous_Successful := Entry_Call.State = Done;
STPO.Unlock (Self_Id);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
Local_Undefer_Abort (Self_Id);
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
end Call_Synchronous;
-- Callable --
--------------
- -- Compiler interface.
- -- Do not call from within the RTS,
- -- except for body of Ada.Task_Identification.
-
- function Callable (T : Task_ID) return Boolean is
+ function Callable (T : Task_Id) return Boolean is
Result : Boolean;
- Self_Id : constant Task_ID := STPO.Self;
+ Self_Id : constant Task_Id := STPO.Self;
begin
- Initialization.Defer_Abort (Self_Id);
+ Initialization.Defer_Abort_Nestable (Self_Id);
+
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
STPO.Write_Lock (T);
Result := T.Callable;
STPO.Unlock (T);
- Initialization.Undefer_Abort (Self_Id);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ Initialization.Undefer_Abort_Nestable (Self_Id);
return Result;
end Callable;
-- 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);
-- Complete_Rendezvous --
-------------------------
- -- See comments for Exceptional_Complete_Rendezvous.
-
procedure Complete_Rendezvous is
begin
Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id);
-- 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.Common.Call;
- Caller : Task_ID;
- Called_PO : STPE.Protection_Entries_Access;
+ Self_Id : constant Task_Id := STPO.Self;
+ Entry_Call : Entry_Call_Link := Self_Id.Common.Call;
+ Caller : Task_Id;
+ Called_PO : STPE.Protection_Entries_Access;
+ Acceptor_Prev_Priority : Integer;
Exception_To_Raise : Ada.Exceptions.Exception_Id := Ex;
Ceiling_Violation : Boolean;
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
+ -- 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.
+ -- Also consider 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.
+
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.
+
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
+ end if;
+
Initialization.Defer_Abort_Nestable (Self_Id);
end if;
-- been serving when it was aborted.
if Ex = Standard'Abort_Signal'Identity then
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
while Entry_Call /= null loop
Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
-- Complete the call abnormally, with exception.
STPO.Write_Lock (Caller);
-
Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
STPO.Unlock (Caller);
Entry_Call := Entry_Call.Acceptor_Prev_Call;
end loop;
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
else
Caller := Entry_Call.Self;
if Entry_Call.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
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
Initialization.Undefer_Abort (Self_Id);
raise Tasking_Error;
end if;
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
else
-- Requeue to a protected entry
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_Do_Or_Queue (Self_Id, Called_PO, Entry_Call);
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);
+ Entry_Calls.Reset_Priority
+ (Self_Id, Entry_Call.Acceptor_Prev_Priority);
else
- -- The call does not need to be requeued.
+ -- The call does not need to be requeued
Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
Entry_Call.Exception_To_Raise := Ex;
+
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
STPO.Write_Lock (Caller);
- -- Done with Caller locked to make sure that Wakeup is not lost.
+ -- Done with Caller locked to make sure that Wakeup is not lost
if Ex /= Ada.Exceptions.Null_Id then
- Ada.Exceptions.Save_Occurrence
- (Caller.Common.Compiler_Data.Current_Excep,
+ Transfer_Occurrence
+ (Caller.Common.Compiler_Data.Current_Excep'Access,
Self_Id.Common.Compiler_Data.Current_Excep);
end if;
+ Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority;
Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+
STPO.Unlock (Caller);
- Entry_Calls.Reset_Priority (Entry_Call.Acceptor_Prev_Priority,
- Self_Id);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
end if;
end if;
Internal_Reraise;
end if;
- -- ?????
- -- Do we need to
- -- give precedence to Program_Error that might be raised
- -- due to failure of finalization, over Tasking_Error from
+ -- ??? 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;
- -------------------
- -- 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;
-
-------------------------------------
-- 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;
+ Acceptor : Task_Id;
E : Task_Entry_Index;
With_Abort : Boolean)
is
Entry_Call.E := Entry_Index (E);
Entry_Call.Called_Task := Acceptor;
Entry_Call.Called_PO := Null_Address;
- Entry_Call.Requeue_With_Abort := With_Abort;
+ Entry_Call.With_Abort := With_Abort;
Object.Call_In_Progress := null;
end Requeue_Protected_To_Task_Entry;
-- 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;
+ (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;
+ 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.With_Abort := With_Abort;
Entry_Call.E := Entry_Index (E);
Entry_Call.Called_Task := Acceptor;
Initialization.Undefer_Abort (Self_Id);
-- 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;
+ Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Link;
Treatment : Select_Treatment;
- Caller : Task_ID;
+ 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
STPO.Unlock (Self_Id);
- -- ??? In some cases abort is deferred more than once. Need to figure
- -- out why.
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ -- ??? In some cases abort is deferred more than once. Need to
+ -- figure out why this happens.
- Self_Id.Deferral_Level := 1;
+ if Self_Id.Deferral_Level > 1 then
+ Self_Id.Deferral_Level := 1;
+ end if;
Initialization.Undefer_Abort (Self_Id);
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);
+ Uninterpreted_Data := Null_Address;
+
Queuing.Select_Task_Entry_Call
(Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
- -- Determine the kind and disposition of the select.
+ -- Determine the kind and disposition of the select
Treatment := Default_Treatment (Select_Mode);
Self_Id.Chosen_Index := No_Rendezvous;
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;
end if;
- -- ??????
- -- Recheck the logic above against the ARM.
-
- -- Handle the select according to the disposition selected above.
+ -- Handle the select according to the disposition selected above
case Treatment is
+ when Accept_Alternative_Selected =>
+ -- Ready to rendezvous
- when Accept_Alternative_Selected =>
-
- -- Ready to rendezvous
-
- Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
+ Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
- -- In this case the accept body is not Null_Body. Defer abortion
- -- until it gets into the accept body.
+ -- In this case the accept body is not Null_Body. Defer abort
+ -- until it gets into the accept body.
- pragma Assert (Self_Id.Deferral_Level = 1);
+ pragma Assert (Self_Id.Deferral_Level = 1);
- Initialization.Defer_Abort_Nestable (Self_Id);
- STPO.Unlock (Self_Id);
+ Initialization.Defer_Abort_Nestable (Self_Id);
+ STPO.Unlock (Self_Id);
- when Accept_Alternative_Completed =>
+ when Accept_Alternative_Completed =>
- -- Accept body is null, so rendezvous is over immediately.
+ -- Accept body is null, so rendezvous is over immediately
- STPO.Unlock (Self_Id);
- Caller := Entry_Call.Self;
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
+ end if;
- STPO.Write_Lock (Caller);
- Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
- STPO.Unlock (Caller);
+ STPO.Unlock (Self_Id);
+ Caller := Entry_Call.Self;
- when Accept_Alternative_Open =>
+ STPO.Write_Lock (Caller);
+ Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+ STPO.Unlock (Caller);
- -- Wait for caller.
+ when Accept_Alternative_Open =>
- Self_Id.Open_Accepts := Open_Accepts;
- pragma Debug
- (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
- Wait_For_Call (Self_Id);
+ -- Wait for caller
- pragma Assert (Self_Id.Open_Accepts = null);
+ Self_Id.Open_Accepts := Open_Accepts;
+ pragma Debug
+ (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
- -- Self_Id.Common.Call should already be updated by the Caller if
- -- not aborted. It might also be ready to do rendezvous even if
- -- this wakes up due to an abortion.
- -- Therefore, if the call is not empty we need to do the rendezvous
- -- if the accept body is not Null_Body.
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (W_Select, Self_Id,
+ Integer (Open_Accepts'Length));
+ end if;
- -- ?????
- -- aren't the first two conditions below redundant?
+ Wait_For_Call (Self_Id);
- 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.Open_Accepts = null);
- pragma Assert (Self_Id.Deferral_Level = 1);
+ -- Self_Id.Common.Call should already be updated by the Caller if
+ -- not aborted. It might also be ready to do rendezvous even if
+ -- this wakes up due to an abort. Therefore, if the call is not
+ -- empty we need to do the rendezvous if the accept body is not
+ -- Null_Body.
- Initialization.Defer_Abort_Nestable (Self_Id);
+ -- Aren't the first two conditions below redundant???
- -- Leave abort deferred until the accept body
- end if;
+ 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;
- STPO.Unlock (Self_Id);
+ pragma Assert
+ (Self_Id.Deferral_Level = 1
+ or else
+ (Self_Id.Deferral_Level = 0
+ and then not Restrictions.Abort_Allowed));
- when Else_Selected =>
- pragma Assert (Self_Id.Open_Accepts = null);
+ Initialization.Defer_Abort_Nestable (Self_Id);
- STPO.Unlock (Self_Id);
+ -- Leave abort deferred until the accept body
+ end if;
- when Terminate_Selected =>
+ STPO.Unlock (Self_Id);
- -- Terminate alternative is open
+ when Else_Selected =>
+ pragma Assert (Self_Id.Open_Accepts = null);
- Self_Id.Open_Accepts := Open_Accepts;
- Self_Id.Common.State := Acceptor_Sleep;
- STPO.Unlock (Self_Id);
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (M_Select_Else);
+ end if;
- -- ?????
- -- 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.
+ STPO.Unlock (Self_Id);
- -- Notify ancestors that this task is on a terminate alternative.
+ when Terminate_Selected =>
+ -- Terminate alternative is open
- Utilities.Make_Passive (Self_Id, Task_Completed => False);
+ Self_Id.Open_Accepts := Open_Accepts;
+ Self_Id.Common.State := Acceptor_Sleep;
- -- Wait for normal entry call or termination
+ -- Notify ancestors that this task is on a terminate alternative
- pragma Assert (Self_Id.ATC_Nesting_Level = 1);
+ STPO.Unlock (Self_Id);
+ Utilities.Make_Passive (Self_Id, Task_Completed => False);
+ STPO.Write_Lock (Self_Id);
- STPO.Write_Lock (Self_Id);
+ -- Wait for normal entry call or termination
- loop
- Initialization.Poll_Base_Priority_Change (Self_Id);
- exit when Self_Id.Open_Accepts = null;
- Sleep (Self_Id, Acceptor_Sleep);
- end loop;
+ Wait_For_Call (Self_Id);
- Self_Id.Common.State := Runnable;
+ pragma Assert (Self_Id.Open_Accepts = null);
- 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.
- if Self_Id.Terminate_Alternative then
+ pragma Assert (Self_Id.Pending_ATC_Level = 0);
+ pragma Assert (Self_Id.Awake_Count = 0);
- -- 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.
+ STPO.Unlock (Self_Id);
- pragma Assert (Self_Id.Pending_ATC_Level = 0);
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
- pragma Assert (Self_Id.Awake_Count = 0);
+ Index := Self_Id.Chosen_Index;
+ Initialization.Undefer_Abort_Nestable (Self_Id);
- -- Trust that it is OK to fall through.
+ if Self_Id.Pending_Action then
+ Initialization.Do_Pending_Action (Self_Id);
+ end if;
- null;
+ return;
- else
- -- Self_Id.Common.Call and Self_Id.Chosen_Index
- -- should already be updated by the Caller.
+ else
+ -- Self_Id.Common.Call and Self_Id.Chosen_Index
+ -- should already be updated by the Caller.
- if Self_Id.Chosen_Index /= No_Rendezvous
- and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
- then
- Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
+ 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);
+ pragma Assert (Self_Id.Deferral_Level = 1);
- -- We need an extra defer here, to keep abort
- -- deferred until we get into the accept body
+ -- We need an extra defer here, to keep abort
+ -- deferred until we get into the accept body
- Initialization.Defer_Abort_Nestable (Self_Id);
+ Initialization.Defer_Abort_Nestable (Self_Id);
+ end if;
end if;
- end if;
- STPO.Unlock (Self_Id);
+ STPO.Unlock (Self_Id);
- when No_Alternative_Open =>
+ 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.
- -- 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.
- -- If delay alternative exists (Delay_Mode) we should suspend
- -- until the delay expires.
+ Self_Id.Open_Accepts := null;
- Self_Id.Open_Accepts := null;
+ if Select_Mode = Delay_Mode then
+ Self_Id.Common.State := Delay_Sleep;
- if Select_Mode = Delay_Mode then
- Self_Id.Common.State := Delay_Sleep;
+ loop
+ exit when
+ Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
+ Sleep (Self_Id, Delay_Sleep);
+ end loop;
- 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);
- Self_Id.Common.State := Runnable;
- STPO.Unlock (Self_Id);
+ else
+ 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;
+ 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;
+
-- Caller has been chosen.
-- Self_Id.Common.Call should already be updated by the Caller.
-- Self_Id.Chosen_Index should either be updated by the Caller
-- or by Test_Selective_Wait.
-- On return, we sill start rendezvous unless the accept body is
- -- null. In the latter case, we will have already completed the RV.
+ -- null. In the latter case, we will have already completed the RV.
Index := Self_Id.Chosen_Index;
Initialization.Undefer_Abort_Nestable (Self_Id);
-
end Selective_Wait;
------------------------------------
-- Setup_For_Rendezvous_With_Body --
------------------------------------
- -- 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
+ Acceptor : Task_Id) is
begin
Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
Acceptor.Common.Call := Entry_Call;
-- 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;
+ 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);
+
+ -- Call Yield to let other tasks get a chance to run as this is a
+ -- potential dispatching point.
+
+ Yield (Do_Yield => False);
return Return_Count;
end Task_Count;
-- 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
+ (Self_ID : Task_Id;
+ Entry_Call : Entry_Call_Link) return Boolean
is
- E : constant Task_Entry_Index := Task_Entry_Index (Entry_Call.E);
- Old_State : constant Entry_Call_State := Entry_Call.State;
- Acceptor : constant Task_ID := Entry_Call.Called_Task;
- Parent : constant Task_ID := Acceptor.Common.Parent;
+ 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;
+ Null_Body : Boolean;
begin
+ -- Find out whether Entry_Call can be accepted immediately
+
+ -- If the Acceptor is not callable, return False.
+ -- If the rendezvous can start, initiate it.
+ -- If the accept-body is trivial, also complete the rendezvous.
+ -- If the acceptor is not ready, enqueue the call.
+
+ -- This should have a special case for Accept_Call and Accept_Trivial,
+ -- so that we don't have the loop setup overhead, below.
+
+ -- The call state Done is used here and elsewhere to include both the
+ -- case of normal successful completion, and the case of an exception
+ -- being raised. The difference is that if an exception is raised no one
+ -- will pay attention to the fact that State = Done. Instead the
+ -- exception will be raised in Undefer_Abort, and control will skip past
+ -- the place where we normally would resume from an entry call.
+
pragma Assert (not Queuing.Onqueue (Entry_Call));
- -- We rely that the call is off-queue for protection,
- -- that the caller will not exit the Entry_Caller_Sleep,
- -- and so will not reuse the call record for another call.
+ -- We rely 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);
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 the acceptor is not callable, abort the call and return False
if not Acceptor.Callable then
STPO.Unlock (Acceptor);
if Parent_Locked then
- STPO.Unlock (Acceptor.Common.Parent);
+ STPO.Unlock (Parent);
end if;
pragma Assert (Entry_Call.State < Done);
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.
+ -- 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.
+ -- 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.
+ -- Prevent abort while call is being served
if Entry_Call.State = Now_Abortable then
Entry_Call.State := Was_Abortable;
if Acceptor.Terminate_Alternative then
- -- Cancel terminate alternative.
- -- See matching code in Selective_Wait and
- -- Vulnerable_Complete_Master.
+ -- 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.
+ -- Notify parent that acceptor is awake
pragma Assert (Parent.Awake_Count > 0);
Parent.Awake_Count := Parent.Awake_Count + 1;
- if Parent.Common.State = Master_Completion_Sleep and then
- Acceptor.Master_of_Task = Parent.Master_Within
+ 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;
if Null_Body then
- -- Rendezvous is over immediately.
+ -- Rendezvous is over immediately
STPO.Wakeup (Acceptor, Acceptor_Sleep);
STPO.Unlock (Acceptor);
else
Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
- -- For terminate_alternative, acceptor may not be
- -- asleep yet, so we skip the wakeup
+ -- For terminate_alternative, acceptor may not be asleep
+ -- yet, so we skip the wakeup
if Acceptor.Common.State /= Runnable then
STPO.Wakeup (Acceptor, Acceptor_Sleep);
end if;
end loop;
- -- The acceptor is accepting, but not this entry.
+ -- The acceptor is accepting, but not this entry
end if;
-- If the acceptor was ready to accept this call,
-- (re)enqueue the call, if the mode permits that.
if Entry_Call.Mode /= Conditional_Call
- or else not With_Abort
+ or else not Entry_Call.With_Abort
then
-- Timed_Call, Simple_Call, or Asynchronous_Call
pragma Assert (Old_State < Done);
- Entry_Call.State := New_State (With_Abort, Entry_Call.State);
+ Entry_Call.State :=
+ New_State (Entry_Call.With_Abort, Entry_Call.State);
STPO.Unlock (Acceptor);
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
+ 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
- Entry_Call.Self /= Self_ID
+ -- Asynchronous_Call or Conditional_Call
then
-- Because of ATCB lock ordering rule
---------------------
procedure Task_Entry_Call
- (Acceptor : Task_ID;
+ (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;
+ Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Link;
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ 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
-- 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.
+ -- Abort must already be deferred by the compiler-generated code.
+ -- Without this, an abort that occurs between the time that this
+ -- call is made and the time that the abortable part's cleanup
+ -- handler is set up might miss the cleanup handler and leave the
+ -- call pending.
Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
pragma Debug
Entry_Call.Called_Task := Acceptor;
Entry_Call.Called_PO := Null_Address;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
+ Entry_Call.With_Abort := True;
+
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
+ STPO.Write_Lock (Self_Id);
+ Utilities.Exit_One_ATC_Level (Self_Id);
+ STPO.Unlock (Self_Id);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
- 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);
+
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (E_Missed, Acceptor);
+ end if;
+
raise Tasking_Error;
end if;
Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
end if;
- -- Note: following assignment needs to be atomic.
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ -- Note: following assignment needs to be atomic
Rendezvous_Successful := Entry_Call.State = Done;
end if;
-- 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;
+ 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);
-- 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;
Mode : Delay_Modes;
Index : out Select_Index)
is
- Self_Id : constant Task_ID := STPO.Self;
+ Self_Id : constant Task_Id := STPO.Self;
Treatment : Select_Treatment;
Entry_Call : Entry_Call_Link;
- Caller : Task_ID;
+ Caller : Task_Id;
Selection : Select_Index;
Open_Alternative : Boolean;
Timedout : Boolean := False;
- Yielded : Boolean := False;
+ Yielded : Boolean := True;
+
begin
pragma Assert (Select_Mode = Delay_Mode);
-- If we are aborted here, the effect will be pending
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
pragma Assert (Self_Id.Pending_Action);
STPO.Unlock (Self_Id);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
Initialization.Undefer_Abort (Self_Id);
-- Should never get here ???
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.
+ Uninterpreted_Data := Null_Address;
pragma Assert (Open_Accepts /= null);
Queuing.Select_Task_Entry_Call
(Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
- -- Determine the kind and disposition of the select.
+ -- Determine the kind and disposition of the select
Treatment := Default_Treatment (Select_Mode);
Self_Id.Chosen_Index := No_Rendezvous;
end if;
end if;
- -- Handle the select according to the disposition selected above.
+ -- Handle the select according to the disposition selected above
case Treatment is
+ when Accept_Alternative_Selected =>
+ -- Ready to rendezvous
+ -- In this case the accept body is not Null_Body. Defer abort
+ -- until it gets into the accept body.
- when Accept_Alternative_Selected =>
+ Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
+ Initialization.Defer_Abort (Self_Id);
+ STPO.Unlock (Self_Id);
- -- Ready to rendezvous
- -- In this case the accept body is not Null_Body. Defer abortion
- -- until it gets into the accept body.
+ when Accept_Alternative_Completed =>
+ -- Rendezvous is over
- Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
- Initialization.Defer_Abort (Self_Id);
- STPO.Unlock (Self_Id);
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
+ end if;
- when Accept_Alternative_Completed =>
+ STPO.Unlock (Self_Id);
+ Caller := Entry_Call.Self;
- -- Rendezvous is over
+ STPO.Write_Lock (Caller);
+ Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+ STPO.Unlock (Caller);
- STPO.Unlock (Self_Id);
- Caller := Entry_Call.Self;
+ when Accept_Alternative_Open =>
- STPO.Write_Lock (Caller);
- Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
- STPO.Unlock (Caller);
+ -- Wait for caller
- when Accept_Alternative_Open =>
+ Self_Id.Open_Accepts := Open_Accepts;
- -- Wait for caller.
+ -- Wait for a normal call and a pending action until the
+ -- Wakeup_Time is reached.
- Self_Id.Open_Accepts := Open_Accepts;
+ Self_Id.Common.State := Acceptor_Sleep;
- -- Wait for a normal call and a pending action until the
- -- Wakeup_Time is reached.
+ -- Try to remove calls to Sleep in the loop below by letting the
+ -- caller a chance of getting ready immediately, using Unlock
+ -- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
- Self_Id.Common.State := Acceptor_Sleep;
+ if Single_Lock then
+ Unlock_RTS;
+ else
+ Unlock (Self_Id);
+ end if;
- loop
- Initialization.Poll_Base_Priority_Change (Self_Id);
- exit when Self_Id.Open_Accepts = null;
+ if Self_Id.Open_Accepts /= null then
+ Yield;
+ end if;
- if Timedout then
- Sleep (Self_Id, Acceptor_Sleep);
+ if Single_Lock then
+ Lock_RTS;
else
- STPO.Timed_Sleep (Self_Id, Timeout, Mode,
- Acceptor_Sleep, Timedout, Yielded);
+ Write_Lock (Self_Id);
end if;
- if Timedout then
+ -- Check if this task has been aborted while the lock was released
+
+ if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
Self_Id.Open_Accepts := null;
end if;
- end loop;
- Self_Id.Common.State := Runnable;
+ loop
+ exit when Self_Id.Open_Accepts = null;
- -- Self_Id.Common.Call should already be updated by the Caller if
- -- not aborted. It might also be ready to do rendezvous even if
- -- this wakes up due to an abortion.
- -- Therefore, if the call is not empty we need to do the rendezvous
- -- if the accept body is not Null_Body.
+ 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;
- 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;
+ STPO.Timed_Sleep (Self_Id, Timeout, Mode,
+ Acceptor_Sleep, Timedout, Yielded);
+ end if;
- pragma Assert (Self_Id.Deferral_Level = 1);
+ if Timedout then
+ Self_Id.Open_Accepts := null;
- Initialization.Defer_Abort_Nestable (Self_Id);
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (E_Timeout);
+ end if;
+ end if;
+ end loop;
- -- Leave abort deferred until the accept body
+ Self_Id.Common.State := Runnable;
- end if;
+ -- Self_Id.Common.Call should already be updated by the Caller if
+ -- not aborted. It might also be ready to do rendezvous even if
+ -- this wakes up due to an abort. Therefore, if the call is not
+ -- empty we need to do the rendezvous if the accept body is not
+ -- Null_Body.
- STPO.Unlock (Self_Id);
- if not Yielded then
- Yield;
- end if;
+ 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;
- when No_Alternative_Open =>
+ pragma Assert (Self_Id.Deferral_Level = 1);
- -- 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
+ Initialization.Defer_Abort_Nestable (Self_Id);
- Self_Id.Open_Accepts := null;
- Self_Id.Common.State := Acceptor_Sleep;
+ -- Leave abort deferred until the accept body
+ end if;
- Initialization.Poll_Base_Priority_Change (Self_Id);
+ STPO.Unlock (Self_Id);
- STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
- Timedout, Yielded);
+ when No_Alternative_Open =>
+ -- In this case, Index will be No_Rendezvous on return. We sleep
+ -- for the time we need to.
+ -- Wait for a signal or timeout. A wakeup can be made
+ -- for several reasons:
+ -- 1) Delay is expired
+ -- 2) Pending_Action needs to be checked
+ -- (Abort, Priority change)
+ -- 3) Spurious wakeup
- Self_Id.Common.State := Runnable;
+ Self_Id.Open_Accepts := null;
+ Self_Id.Common.State := Acceptor_Sleep;
- STPO.Unlock (Self_Id);
+ STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
+ Timedout, Yielded);
- if not Yielded then
- Yield;
- end if;
+ Self_Id.Common.State := Runnable;
- when others =>
- -- Should never get here ???
+ STPO.Unlock (Self_Id);
- pragma Assert (False);
- null;
+ when others =>
+ -- Should never get here
+ pragma Assert (False);
+ null;
end case;
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ if not Yielded then
+ Yield;
+ end if;
+
-- Caller has been chosen
-- Self_Id.Common.Call should already be updated by the Caller
Initialization.Undefer_Abort_Nestable (Self_Id);
-- Start rendezvous, if not already completed
-
end Timed_Selective_Wait;
---------------------------
-- Timed_Task_Entry_Call --
---------------------------
- -- Compiler interface only. Do not call from within the RTS.
-
procedure Timed_Task_Entry_Call
- (Acceptor : Task_ID;
+ (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;
+ Self_Id : constant Task_Id := STPO.Self;
Level : ATC_Level;
Entry_Call : Entry_Call_Link;
+ Yielded : Boolean;
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ 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;
(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.Called_Task := Acceptor;
Entry_Call.Called_PO := Null_Address;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
+ Entry_Call.With_Abort := True;
- -- Note: the caller will undefer abortion on return (see WARNING above)
+ -- Note: the caller will undefer abort 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;
+ if Single_Lock then
+ Lock_RTS;
+ end if;
- pragma Debug
- (Debug.Trace (Self_Id, "TTEC: exited to ATC level: " &
- ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
+ if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
+ STPO.Write_Lock (Self_Id);
+ Utilities.Exit_One_ATC_Level (Self_Id);
+ STPO.Unlock (Self_Id);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
Initialization.Undefer_Abort (Self_Id);
+
+ if Parameters.Runtime_Traces then
+ Send_Trace_Info (E_Missed, Acceptor);
+ end if;
raise Tasking_Error;
end if;
+ Write_Lock (Self_Id);
Entry_Calls.Wait_For_Completion_With_Timeout
- (Self_Id, Entry_Call, Timeout, Mode);
+ (Entry_Call, Timeout, Mode, Yielded);
+ Unlock (Self_Id);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ -- ??? Do we need to yield in case Yielded is False
+
Rendezvous_Successful := Entry_Call.State = Done;
Initialization.Undefer_Abort (Self_Id);
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
-- 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
+ procedure Wait_For_Call (Self_Id : Task_Id) is
begin
Self_Id.Common.State := Acceptor_Sleep;
- loop
- Initialization.Poll_Base_Priority_Change (Self_Id);
+ -- Try to remove calls to Sleep in the loop below by letting the caller
+ -- a chance of getting ready immediately, using Unlock & Yield.
+ -- See similar action in Wait_For_Completion & Timed_Selective_Wait.
- exit when Self_Id.Open_Accepts = null;
+ if Single_Lock then
+ Unlock_RTS;
+ else
+ Unlock (Self_Id);
+ end if;
+ if Self_Id.Open_Accepts /= null then
+ Yield;
+ end if;
+
+ if Single_Lock then
+ Lock_RTS;
+ else
+ Write_Lock (Self_Id);
+ end if;
+
+ -- Check if this task has been aborted while the lock was released
+
+ if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
+ Self_Id.Open_Accepts := null;
+ end if;
+
+ loop
+ exit when Self_Id.Open_Accepts = null;
Sleep (Self_Id, Acceptor_Sleep);
end loop;
OSDN Git Service
