-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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- --
-- 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. (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
+-- Transfer_Occurrence
-- Raise_Exception
with System.Task_Primitives.Operations;
-- 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
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
-- 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.
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
(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;
--------------------
procedure Accept_Trivial (E : Task_Entry_Index) 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;
-- Boost_Priority --
--------------------
- procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_ID) is
- Caller : constant 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
-----------------
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 --
----------------------
- -- Called from 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;
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;
+ 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);
- 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;
-- Callable --
--------------
- 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);
procedure Exceptional_Complete_Rendezvous
(Ex : Ada.Exceptions.Exception_Id)
is
- Self_Id : constant Task_ID := STPO.Self;
+ Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Link := Self_Id.Common.Call;
- Caller : Task_ID;
+ Caller : Task_Id;
Called_PO : STPE.Protection_Entries_Access;
Exception_To_Raise : Ada.Exceptions.Exception_Id := Ex;
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
(Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort)
then
if Single_Lock then
- Lock_RTS;
+ Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
(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;
-- 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;
-- 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 --
-------------------------------------
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
------------------------
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;
+ Self_Id : constant Task_Id := STPO.Self;
Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
begin
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;
-- ??? 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);
Self_Id.Open_Accepts := Open_Accepts;
Self_Id.Common.State := Acceptor_Sleep;
- STPO.Unlock (Self_Id);
-- Notify ancestors that this task is on a terminate alternative.
+ STPO.Unlock (Self_Id);
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;
+ -- Wait for normal entry call or termination
- Self_Id.Common.State := Runnable;
+ Wait_For_Call (Self_Id);
pragma Assert (Self_Id.Open_Accepts = null);
-- 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;
----------------
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
----------------------
function Task_Do_Or_Queue
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
With_Abort : Boolean) return Boolean
is
E : constant Task_Entry_Index :=
Task_Entry_Index (Entry_Call.E);
Old_State : constant Entry_Call_State := Entry_Call.State;
- Acceptor : constant Task_ID := Entry_Call.Called_Task;
- Parent : constant Task_ID := Acceptor.Common.Parent;
+ Acceptor : constant Task_Id := Entry_Call.Called_Task;
+ Parent : constant Task_Id := Acceptor.Common.Parent;
Parent_Locked : Boolean := False;
Null_Body : Boolean;
---------------------
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 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'));
+ STPO.Write_Lock (Self_Id);
+ Utilities.Exit_One_ATC_Level (Self_Id);
+ STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
-- Task_Entry_Caller --
-----------------------
- 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
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;
-- 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.
+
+ 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;
+
Self_Id.Common.State := Acceptor_Sleep;
loop
---------------------------
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;
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'));
+ STPO.Write_Lock (Self_Id);
+ Utilities.Exit_One_ATC_Level (Self_Id);
+ STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
-- 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
+ -- 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 & Selective_Wait.
+
+ 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;
+
Self_Id.Common.State := Acceptor_Sleep;
loop
OSDN Git Service
