@@ -96,6 +96,7 @@ package body System.Tasking.Async_Delays is
-- for an async. select statement with delay statement as trigger. The
-- effect should be to remove the delay from the timer queue, and exit one
-- ATC nesting level.
+
-- The usage and logic are similar to Cancel_Protected_Entry_Call, but
-- simplified because this is not a true entry call.
@@ -104,18 +105,17 @@ package body System.Tasking.Async_Delays is
Dsucc : Delay_Block_Access;
begin
- -- Note that we mark the delay as being cancelled
- -- using a level value that is reserved.
-
- -- make this operation idempotent
+ -- A delay block level of Level_No_Pending_Abort indicates the delay
+ -- has been cancelled. If the delay has already been canceled, there is
+ -- nothing more to be done.
- if D.Level = ATC_Level_Infinity then
+ if D.Level = Level_No_Pending_Abort then
return;
end if;
- D.Level := ATC_Level_Infinity;
+ D.Level := Level_No_Pending_Abort;
- -- remove self from timer queue
+ -- Remove self from timer queue
STI.Defer_Abort_Nestable (D.Self_Id);
@@ -120,8 +120,8 @@ private
Level : ATC_Level_Base;
-- Normally Level is the ATC nesting level of the asynchronous select
-- statement to which this delay belongs, but after a call has been
- -- dequeued we set it to ATC_Level_Infinity so that the Cancel operation
- -- can detect repeated calls, and act idempotently.
+ -- dequeued we set it to Level_No_Pending_Abort so that the Cancel
+ -- operation can detect repeated calls, and act idempotently.
Resume_Time : Duration;
-- The absolute wake up time, represented as Duration
@@ -615,7 +615,7 @@ package body System.Tasking.Entry_Calls is
Call : Entry_Call_Link)
is
begin
- pragma Assert (Self_ID.ATC_Nesting_Level > 0);
+ pragma Assert (Self_ID.ATC_Nesting_Level > Level_No_ATC_Occuring);
pragma Assert (Call.Mode = Asynchronous_Call);
STPO.Write_Lock (Self_ID);
@@ -562,7 +562,16 @@ package body System.Tasking.Restricted.Stages is
raise Program_Error;
end if;
- Created_Task.Entry_Calls (1).Self := Created_Task;
+ -- Only the first element of the Entry_Calls array is used when the
+ -- Ravenscar Profile is active as no asynchronous transfer of control
+ -- is allowed.
+
+ Created_Task.Entry_Calls (Created_Task.Entry_Calls'First) :=
+ (Self => Created_Task,
+ Level => Created_Task.Entry_Calls'First,
+ others => <>);
+
+ -- Set task name
Len :=
Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length);
@@ -426,7 +426,7 @@ package body System.Tasking.Initialization is
procedure Locked_Abort_To_Level
(Self_ID : Task_Id;
T : Task_Id;
- L : ATC_Level)
+ L : ATC_Level_Base)
is
begin
if not T.Aborting and then T /= Self_ID then
@@ -440,11 +440,13 @@ package body System.Tasking.Initialization is
when Activating
| Runnable
=>
- -- This is needed to cancel an asynchronous protected entry
- -- call during a requeue with abort.
+ if T.ATC_Nesting_Level > Level_No_ATC_Occuring then
+ -- This scenario occurs when an asynchronous protected entry
+ -- call is canceld during a requeue with abort.
- T.Entry_Calls
- (T.ATC_Nesting_Level).Cancellation_Attempted := True;
+ T.Entry_Calls
+ (T.ATC_Nesting_Level).Cancellation_Attempted := True;
+ end if;
when Interrupt_Server_Blocked_On_Event_Flag =>
null;
@@ -465,6 +467,8 @@ package body System.Tasking.Initialization is
Wakeup (T, T.Common.State);
when Entry_Caller_Sleep =>
+ pragma Assert (T.ATC_Nesting_Level > Level_No_ATC_Occuring);
+
T.Entry_Calls
(T.ATC_Nesting_Level).Cancellation_Attempted := True;
Wakeup (T, T.Common.State);
@@ -482,7 +486,7 @@ package body System.Tasking.Initialization is
T.Pending_ATC_Level := L;
T.Pending_Action := True;
- if L = 0 then
+ if L = Level_Completed_Task then
T.Callable := False;
end if;
@@ -171,7 +171,7 @@ package System.Tasking.Initialization is
procedure Locked_Abort_To_Level
(Self_ID : Task_Id;
T : Task_Id;
- L : ATC_Level);
+ L : ATC_Level_Base);
pragma Inline (Locked_Abort_To_Level);
-- Abort a task to a specified ATC level. Call this only with T locked
@@ -267,9 +267,12 @@ package body System.Tasking is
Dispatching_Domain_Tasks (Base_CPU) + 1;
end if;
- -- Only initialize the first element since others are not relevant
- -- in ravenscar mode. Rest of the initialization is done in Init_RTS.
+ -- The full initialization of the environment task's Entry_Calls array
+ -- is deferred to Init_RTS because only the first element of the array
+ -- is used by the restricted Ravenscar runtime.
+
+ T.Entry_Calls (T.Entry_Calls'First).Self := T;
+ T.Entry_Calls (T.Entry_Calls'First).Level := T.Entry_Calls'First;
- T.Entry_Calls (1).Self := T;
end Initialize;
end System.Tasking;
@@ -565,7 +565,8 @@ package System.Tasking is
--
-- Protection: Self.L. Self will modify this field when Self.Accepting
-- is False, and will not need the mutex to do so. Once a task sets
- -- Pending_ATC_Level = 0, no other task can access this field.
+ -- Pending_ATC_Level = Level_Completed_Task, no other task can access
+ -- this field.
LL : aliased Task_Primitives.Private_Data;
-- Control block used by the underlying low-level tasking service
@@ -814,14 +815,32 @@ package System.Tasking is
-----------------------------------
Max_ATC_Nesting : constant Natural := 20;
+ -- The maximum number of nested asynchronous select statements supported
+ -- by the runtime.
- subtype ATC_Level_Base is Integer range 0 .. Max_ATC_Nesting;
+ subtype ATC_Level_Base is Integer range -1 .. Max_ATC_Nesting;
+ -- Indicates the number of nested asynchronous task control statements
+ -- or entries a task is in.
- ATC_Level_Infinity : constant ATC_Level_Base := ATC_Level_Base'Last;
+ Level_Completed_Task : constant ATC_Level_Base := -1;
+ -- ATC_Level of a task that has "completed". A task reaches the completed
+ -- state after an abort, exception propagation, or normal exit.
- subtype ATC_Level is ATC_Level_Base range 0 .. ATC_Level_Base'Last - 1;
+ Level_No_ATC_Occuring : constant ATC_Level_Base := 0;
+ -- ATC_Level of a task not executing a entry call or an asynchronous
+ -- select statement.
- subtype ATC_Level_Index is ATC_Level range 1 .. ATC_Level'Last;
+ Level_No_Pending_Abort : constant ATC_Level_Base := ATC_Level_Base'Last;
+ -- ATC_Level when there is no pending abort
+
+ subtype ATC_Level is ATC_Level_Base range
+ Level_No_ATC_Occuring .. Level_No_Pending_Abort - 1;
+ -- Nested ATC_Levels valid during the execution of a task
+
+ subtype ATC_Level_Index is ATC_Level range
+ Level_No_ATC_Occuring + 1 .. ATC_Level'Last;
+ -- ATC_Levels valid when a task is executing an entry call or asynchronous
+ -- task control statements.
----------------------------------
-- Entry_Call_Record definition --
@@ -1082,7 +1101,7 @@ package System.Tasking is
-- Beginning of counts
- ATC_Nesting_Level : ATC_Level := 1;
+ ATC_Nesting_Level : ATC_Level := Level_No_ATC_Occuring;
-- The dynamic level of ATC nesting (currently executing nested
-- asynchronous select statements) in this task.
@@ -1102,13 +1121,17 @@ package System.Tasking is
-- Protection: Only updated by Self; access assumed to be atomic
- Pending_ATC_Level : ATC_Level_Base := ATC_Level_Infinity;
- -- The ATC level to which this task is currently being aborted. If the
- -- value is zero, the entire task has "completed". That may be via
- -- abort, exception propagation, or normal exit. If the value is
- -- ATC_Level_Infinity, the task is not being aborted to any level. If
- -- the value is positive, the task has not completed. This should ONLY
- -- be modified by Abort_To_Level and Exit_One_ATC_Level.
+ Pending_ATC_Level : ATC_Level_Base := Level_No_Pending_Abort;
+ -- Indicates the ATC level to which this task is currently being
+ -- aborted. Two special values exist:
+ --
+ -- * Level_Completed_Task: the task has completed.
+ --
+ -- * Level_No_Pending_Abort: the task is not being aborted to any
+ -- level.
+ --
+ -- All other values indicate the task has not completed. This should
+ -- ONLY be modified by Abort_To_Level and Exit_One_ATC_Level.
--
-- Protection: Self.L
@@ -163,7 +163,7 @@ package body System.Tasking.Rendezvous is
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
- pragma Assert (Self_Id.Pending_ATC_Level = 0);
+ pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task);
pragma Assert (Self_Id.Pending_Action);
@@ -205,6 +205,9 @@ package body System.Tasking.Rendezvous is
if Self_Id.Common.Call /= null then
Caller := Self_Id.Common.Call.Self;
+
+ pragma Assert (Caller.ATC_Nesting_Level > Level_No_ATC_Occuring);
+
Uninterpreted_Data :=
Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
else
@@ -247,7 +250,7 @@ package body System.Tasking.Rendezvous is
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
- pragma Assert (Self_Id.Pending_ATC_Level = 0);
+ pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task);
pragma Assert (Self_Id.Pending_Action);
@@ -738,7 +741,7 @@ package body System.Tasking.Rendezvous is
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
- pragma Assert (Self_Id.Pending_ATC_Level = 0);
+ pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task);
pragma Assert (Self_Id.Pending_Action);
@@ -893,7 +896,8 @@ package body System.Tasking.Rendezvous is
-- 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.Pending_ATC_Level = Level_Completed_Task);
pragma Assert (Self_Id.Awake_Count = 0);
STPO.Unlock (Self_Id);
@@ -1395,7 +1399,7 @@ package body System.Tasking.Rendezvous is
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
- pragma Assert (Self_Id.Pending_ATC_Level = 0);
+ pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task);
pragma Assert (Self_Id.Pending_Action);
@@ -588,7 +588,7 @@ package body System.Tasking.Stages is
-- give up on creating this task, and simply return.
if not Self_ID.Callable then
- pragma Assert (Self_ID.Pending_ATC_Level = 0);
+ pragma Assert (Self_ID.Pending_ATC_Level = Level_Completed_Task);
pragma Assert (Self_ID.Pending_Action);
pragma Assert
(Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated);
@@ -1553,7 +1553,9 @@ package body System.Tasking.Stages is
-- for the task completion is an abort, we do not raise an exception.
-- See RM 9.2(5).
- if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
+ if not Self_ID.Callable
+ and then Self_ID.Pending_ATC_Level /= Level_Completed_Task
+ then
Activator.Common.Activation_Failed := True;
end if;
@@ -1980,7 +1982,7 @@ package body System.Tasking.Stages is
Self_ID.Master_Of_Task .. Self_ID.Master_Of_Task + 3);
pragma Assert (Self_ID.Common.Wait_Count = 0);
pragma Assert (Self_ID.Open_Accepts = null);
- pragma Assert (Self_ID.ATC_Nesting_Level = 1);
+ pragma Assert (Self_ID.ATC_Nesting_Level = Level_No_ATC_Occuring);
pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
@@ -56,7 +56,8 @@ package body System.Tasking.Utilities is
-- Abort_One_Task --
--------------------
- -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but:
+ -- Similar to Locked_Abort_To_Level (Self_ID, T, Level_Completed_Task),
+ -- but:
-- (1) caller should be holding no locks except RTS_Lock when Single_Lock
-- (2) may be called for tasks that have not yet been activated
-- (3) always aborts whole task
@@ -72,7 +73,8 @@ package body System.Tasking.Utilities is
Cancel_Queued_Entry_Calls (T);
elsif T.Common.State /= Terminated then
- Initialization.Locked_Abort_To_Level (Self_ID, T, 0);
+ Initialization.Locked_Abort_To_Level
+ (Self_ID, T, Level_Completed_Task);
end if;
Unlock (T);
@@ -123,11 +125,11 @@ package body System.Tasking.Utilities is
C := All_Tasks_List;
while C /= null loop
- if C.Pending_ATC_Level > 0 then
+ if C.Pending_ATC_Level > Level_Completed_Task then
P := C.Common.Parent;
while P /= null loop
- if P.Pending_ATC_Level = 0 then
+ if P.Pending_ATC_Level = Level_Completed_Task then
Abort_One_Task (Self_Id, C);
exit;
end if;
@@ -204,23 +206,24 @@ package body System.Tasking.Utilities is
procedure Exit_One_ATC_Level (Self_ID : Task_Id) is
begin
+ pragma Assert (Self_ID.ATC_Nesting_Level > Level_No_ATC_Occuring);
+
Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;
pragma Debug
(Debug.Trace (Self_ID, "EOAL: exited to ATC level: " &
ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
- pragma Assert (Self_ID.ATC_Nesting_Level >= 1);
+ if Self_ID.Pending_ATC_Level < Level_No_Pending_Abort then
- if Self_ID.Pending_ATC_Level < ATC_Level_Infinity then
if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then
- Self_ID.Pending_ATC_Level := ATC_Level_Infinity;
+ Self_ID.Pending_ATC_Level := Level_No_Pending_Abort;
Self_ID.Aborting := False;
else
-- Force the next Undefer_Abort to re-raise Abort_Signal
pragma Assert
- (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level);
+ (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level);
if Self_ID.Aborting then
Self_ID.ATC_Hack := True;
@@ -111,7 +111,8 @@ package System.Tasking.Utilities is
-- The effect is to exit one level of ATC nesting.
procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id);
- -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but:
+ -- Similar to Locked_Abort_To_Level (Self_ID, T, Level_Completed_Task),
+ -- but:
-- (1) caller should be holding no locks
-- (2) may be called for tasks that have not yet been activated
-- (3) always aborts whole task
@@ -341,7 +341,8 @@ package body System.Tasking.Protected_Objects.Single_Entry is
Uninterpreted_Data : System.Address)
is
Self_Id : constant Task_Id := STPO.Self;
- Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
+ Entry_Call : Entry_Call_Record renames
+ Self_Id.Entry_Calls (Self_Id.Entry_Calls'First);
begin
-- If pragma Detect_Blocking is active then Program_Error must be
-- raised if this potentially blocking operation is called from a