From patchwork Mon Dec 3 15:51:15 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1007030 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-491517-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="OEQYJ/Bu"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 437qHB5JZXz9s7W for ; Tue, 4 Dec 2018 02:51:34 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=O9jumfMP4e43KcPGhNoz9+bu5scUR9E2orQsEg+42ifnWKrSyN 11h8ViQsYi1G5eUBOJGVJHxwaddNMB9B4I9ZpsXrETaphmD2UbN/wt7buTLQqxu4 EJtB+mSxOJ5tugwz0aYEGE58jIOvJCyiPOOV5WafKJsuk1OtlRUZTG+fE= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=iaIDV4+Oq0Olsc8rZ6f7IW0MThM=; b=OEQYJ/BueOKki19d29sa FJf0GotICfnl1GFKLc/m9y+JvS7XxGadVIW7RVTVOTXI/t+jUcF7nnHFUgljgogj 4ZtMMIrxcVjWGN+vorBwPtrjuHvuchuRAzPHimpIJlvQItw/p5m5zCVtH18iq5ii 3Q2+DdquyXdaBBj0p4nMooo= Received: (qmail 31135 invoked by alias); 3 Dec 2018 15:51:26 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 31116 invoked by uid 89); 3 Dec 2018 15:51:26 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-16.9 required=5.0 tests=BAYES_00, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=Duration, patrick, Control, 92 X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 03 Dec 2018 15:51:17 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 0C29E116573; Mon, 3 Dec 2018 10:51:16 -0500 (EST) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id g-ga0NKFn3aV; Mon, 3 Dec 2018 10:51:15 -0500 (EST) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id ED07D1163EB; Mon, 3 Dec 2018 10:51:15 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4862) id EBF773561; Mon, 3 Dec 2018 10:51:15 -0500 (EST) Date: Mon, 3 Dec 2018 10:51:15 -0500 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Patrick Bernardi Subject: [Ada] A task not executing an entry call consumes an Entry_Call slot Message-ID: <20181203155115.GA28321@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes 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; Tested on x86_64-pc-linux-gnu, committed on trunk 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. --- gcc/ada/libgnarl/s-taasde.adb +++ 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); --- gcc/ada/libgnarl/s-taasde.ads +++ 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 --- gcc/ada/libgnarl/s-taenca.adb +++ 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); --- gcc/ada/libgnarl/s-tarest.adb +++ 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); --- gcc/ada/libgnarl/s-tasini.adb +++ 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; --- gcc/ada/libgnarl/s-tasini.ads +++ 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 --- gcc/ada/libgnarl/s-taskin.adb +++ 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; --- gcc/ada/libgnarl/s-taskin.ads +++ 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 --- gcc/ada/libgnarl/s-tasren.adb +++ 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); --- gcc/ada/libgnarl/s-tassta.adb +++ 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')); --- gcc/ada/libgnarl/s-tasuti.adb +++ 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; --- gcc/ada/libgnarl/s-tasuti.ads +++ 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 --- gcc/ada/libgnarl/s-tposen.adb +++ 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