From c899d4bafcad17c7d493123cdf75ce4f54e0f8c1 Mon Sep 17 00:00:00 2001 From: Patrick Bernardi Date: Mon, 3 Dec 2018 15:49:06 +0000 Subject: [PATCH] [Ada] A task not executing an entry call consumes an Entry_Call slot This patch resolves the issue where the ATC Level of a task's first Entry_Call slot corresponds to a task not currently making an entry call. Consequently, the first slot is never used to record an entry call. To resolve this, the ATC Level of a such a task is now one less than the first index of the Entry_Call array (and as result, the ATC level corresponding to a completed task is now two less than the first index of this array). To aid the maintainability of code using ATC levels new constants are introduced to represent key ATC nesting levels and comments are introduce for the ATC level definitions. As a result of this change, the GNAT Extended Ravenscar Profile now works with the full runtime. The restricted runtime had assumed that the first Entry_Call slot would be the only slot used for entry calls and would only initialise this slot (and System.Tasking.Protected_Objects.Single_Entry was coded this way). However, Extended Ravenscar uses the native implementation of System.Tasking.Protected_Objects where this assumption doesn't hold until the implementation of this patch. Aside from enabling an extra nested level, this is main functional change of this patch. The following should compile and execute quietly: gprbuild -q main.adb ./main -- main.adb pragma Profile (GNAT_Extended_Ravenscar); pragma Partition_Elaboration_Policy (Sequential); with Tasks; with GNAT.OS_Lib; with Ada.Synchronous_Task_Control; procedure Main is pragma Priority (30); begin Ada.Synchronous_Task_Control.Suspend_Until_True (Tasks.A_SO); Ada.Synchronous_Task_Control.Suspend_Until_True (Tasks.B_SO); GNAT.OS_Lib.OS_Exit (0); end Main; -- tasks.ads with Ada.Synchronous_Task_Control; package Tasks is A_SO : Ada.Synchronous_Task_Control.Suspension_Object; B_SO : Ada.Synchronous_Task_Control.Suspension_Object; task A with Priority => 25; task B with Priority => 20; end Tasks; -- tasks.adb with Obj; package body Tasks is task body A is begin for J in 1 .. 5 loop Obj.PO.Wait; end loop; Ada.Synchronous_Task_Control.Set_True (Tasks.A_SO); end A; task body B is begin for J in 1 .. 5 loop Obj.PO.Put; end loop; Ada.Synchronous_Task_Control.Set_True (Tasks.B_SO); end B; end Tasks; -- obj.ads package Obj is protected type PT is pragma Priority (30); entry Put; entry Wait; private Wait_Ready : Boolean := False; Put_Ready : Boolean := True; end PT; PO : PT; end Obj; -- obj.adb package body Obj is protected body PT is entry Put when Put_Ready is begin Wait_Ready := True; Put_Ready := False; end Put; entry Wait when Wait_Ready is begin Wait_Ready := False; Put_Ready := True; end Wait; end PT; end Obj; 2018-12-03 Patrick Bernardi gcc/ada/ * libgnarl/s-taskin.ads (ATC_Level_Base): Redefine to span from -1 to Max_ATC_Nesting so that 0 represents no ATC nesting and -1 represented a completed task. To increase readability, new constants are introduced to represent key ATC nesting levels. Consequently, Level_No_Pending_Abort replaces ATC_Level_Infinity. ATC_Level related definitions now documented. (Ada_Task_Control_Block): The default initialization of components ATC_Nesting_Level and Pending_ATC_Level now use new ATC_Level_Base constants. Comments improved * libgnarl/s-taskin.adb (Initialize): Improve the initialisation of the first element of the Entry_Calls array to facilitate better maintenance. * libgnarl/s-taasde.ads: Update comment. * libgnarl/s-taasde.adb, libgnarl/s-taenca.adb, libgnarl/s-tasren.adb, libgnarl/s-tassta.adb, libgnarl/s-tasuti.ads, libgnarl/s-tasuti.adb: Use new ATC_Level_Base constants. * libgnarl/s-tarest.adb (Create_Restricted_Task): Improve the initialisation of the first element of the task's Entry_Calls array to facilitate better maintenance. * libgnarl/s-tasini.ads (Locked_Abort_To_Level): Update signature to accept ATC_Level_Base. * libgnarl/s-tasini.adb (Locked_Abort_To_Level): Update signature to accept ATC_Level_Base. Use new ATC_Level_Base constants and only modify the aborting task's Entry_Calls array if any entry call is happening. * libgnarl/s-tposen.adb (Protected_Single_Entry_Call): Reference the first element of the task's Entry_Calls array via 'First attribute to facilitate better maintenance. From-SVN: r266752 --- gcc/ada/ChangeLog | 33 +++++++++++++++++++++++ gcc/ada/libgnarl/s-taasde.adb | 14 +++++----- gcc/ada/libgnarl/s-taasde.ads | 4 +-- gcc/ada/libgnarl/s-taenca.adb | 2 +- gcc/ada/libgnarl/s-tarest.adb | 11 +++++++- gcc/ada/libgnarl/s-tasini.adb | 16 +++++++----- gcc/ada/libgnarl/s-tasini.ads | 2 +- gcc/ada/libgnarl/s-taskin.adb | 9 ++++--- gcc/ada/libgnarl/s-taskin.ads | 49 +++++++++++++++++++++++++---------- gcc/ada/libgnarl/s-tasren.adb | 14 ++++++---- gcc/ada/libgnarl/s-tassta.adb | 8 +++--- gcc/ada/libgnarl/s-tasuti.adb | 19 ++++++++------ gcc/ada/libgnarl/s-tasuti.ads | 3 ++- gcc/ada/libgnarl/s-tposen.adb | 3 ++- 14 files changed, 135 insertions(+), 52 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 49bf8c26dae..dae657493a0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2018-12-03 Patrick Bernardi + + * libgnarl/s-taskin.ads (ATC_Level_Base): Redefine to span from + -1 to Max_ATC_Nesting so that 0 represents no ATC nesting and -1 + represented a completed task. To increase readability, new + constants are introduced to represent key ATC nesting levels. + Consequently, Level_No_Pending_Abort replaces + ATC_Level_Infinity. ATC_Level related definitions now + documented. + (Ada_Task_Control_Block): The default initialization of + components ATC_Nesting_Level and Pending_ATC_Level now use new + ATC_Level_Base constants. Comments improved + * libgnarl/s-taskin.adb (Initialize): Improve the initialisation + of the first element of the Entry_Calls array to facilitate + better maintenance. + * libgnarl/s-taasde.ads: Update comment. + * libgnarl/s-taasde.adb, libgnarl/s-taenca.adb, + libgnarl/s-tasren.adb, libgnarl/s-tassta.adb, + libgnarl/s-tasuti.ads, libgnarl/s-tasuti.adb: Use new + ATC_Level_Base constants. + * libgnarl/s-tarest.adb (Create_Restricted_Task): Improve the + initialisation of the first element of the task's Entry_Calls + array to facilitate better maintenance. + * libgnarl/s-tasini.ads (Locked_Abort_To_Level): Update + signature to accept ATC_Level_Base. + * libgnarl/s-tasini.adb (Locked_Abort_To_Level): Update + signature to accept ATC_Level_Base. Use new ATC_Level_Base + constants and only modify the aborting task's Entry_Calls array + if any entry call is happening. + * libgnarl/s-tposen.adb (Protected_Single_Entry_Call): Reference + the first element of the task's Entry_Calls array via 'First + attribute to facilitate better maintenance. + 2018-12-03 Eric Botcazou * einfo.adb (Write_Entity_Info): Don't take Scope of Standard diff --git a/gcc/ada/libgnarl/s-taasde.adb b/gcc/ada/libgnarl/s-taasde.adb index 78f5b0fc2b8..4f5b3e48185 100644 --- a/gcc/ada/libgnarl/s-taasde.adb +++ b/gcc/ada/libgnarl/s-taasde.adb @@ -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); diff --git a/gcc/ada/libgnarl/s-taasde.ads b/gcc/ada/libgnarl/s-taasde.ads index 5c78da8c29d..22e1ca07516 100644 --- a/gcc/ada/libgnarl/s-taasde.ads +++ b/gcc/ada/libgnarl/s-taasde.ads @@ -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 diff --git a/gcc/ada/libgnarl/s-taenca.adb b/gcc/ada/libgnarl/s-taenca.adb index 05b77b58690..965bd1d531e 100644 --- a/gcc/ada/libgnarl/s-taenca.adb +++ b/gcc/ada/libgnarl/s-taenca.adb @@ -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); diff --git a/gcc/ada/libgnarl/s-tarest.adb b/gcc/ada/libgnarl/s-tarest.adb index b07e686983f..1966a9163d8 100644 --- a/gcc/ada/libgnarl/s-tarest.adb +++ b/gcc/ada/libgnarl/s-tarest.adb @@ -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); diff --git a/gcc/ada/libgnarl/s-tasini.adb b/gcc/ada/libgnarl/s-tasini.adb index 3d642f47cdd..2164c19d537 100644 --- a/gcc/ada/libgnarl/s-tasini.adb +++ b/gcc/ada/libgnarl/s-tasini.adb @@ -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; diff --git a/gcc/ada/libgnarl/s-tasini.ads b/gcc/ada/libgnarl/s-tasini.ads index 21d7414f0a8..6bd865c8786 100644 --- a/gcc/ada/libgnarl/s-tasini.ads +++ b/gcc/ada/libgnarl/s-tasini.ads @@ -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 diff --git a/gcc/ada/libgnarl/s-taskin.adb b/gcc/ada/libgnarl/s-taskin.adb index b35181aa0a5..d86a2b8ebc4 100644 --- a/gcc/ada/libgnarl/s-taskin.adb +++ b/gcc/ada/libgnarl/s-taskin.adb @@ -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; diff --git a/gcc/ada/libgnarl/s-taskin.ads b/gcc/ada/libgnarl/s-taskin.ads index 673d3cd3d44..1bc33d17b92 100644 --- a/gcc/ada/libgnarl/s-taskin.ads +++ b/gcc/ada/libgnarl/s-taskin.ads @@ -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 diff --git a/gcc/ada/libgnarl/s-tasren.adb b/gcc/ada/libgnarl/s-tasren.adb index ce6583a552d..5ce200a9495 100644 --- a/gcc/ada/libgnarl/s-tasren.adb +++ b/gcc/ada/libgnarl/s-tasren.adb @@ -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); diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb index fe982e236b2..b48f2384a65 100644 --- a/gcc/ada/libgnarl/s-tassta.adb +++ b/gcc/ada/libgnarl/s-tassta.adb @@ -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')); diff --git a/gcc/ada/libgnarl/s-tasuti.adb b/gcc/ada/libgnarl/s-tasuti.adb index 32c2c69b98a..f3708fde710 100644 --- a/gcc/ada/libgnarl/s-tasuti.adb +++ b/gcc/ada/libgnarl/s-tasuti.adb @@ -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; diff --git a/gcc/ada/libgnarl/s-tasuti.ads b/gcc/ada/libgnarl/s-tasuti.ads index b4eff795ed1..72d1ccc0dc3 100644 --- a/gcc/ada/libgnarl/s-tasuti.ads +++ b/gcc/ada/libgnarl/s-tasuti.ads @@ -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 diff --git a/gcc/ada/libgnarl/s-tposen.adb b/gcc/ada/libgnarl/s-tposen.adb index 89319fa767f..bb747510659 100644 --- a/gcc/ada/libgnarl/s-tposen.adb +++ b/gcc/ada/libgnarl/s-tposen.adb @@ -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 -- 2.30.2