From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wr1-x432.google.com (mail-wr1-x432.google.com [IPv6:2a00:1450:4864:20::432]) by sourceware.org (Postfix) with ESMTPS id 584BC3883017 for ; Tue, 23 May 2023 08:09:12 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 584BC3883017 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-wr1-x432.google.com with SMTP id ffacd0b85a97d-30a8fa6e6fcso1504677f8f.1 for ; Tue, 23 May 2023 01:09:12 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1684829350; x=1687421350; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=DyLKHZ4ETQWRD0C327pl5xS+7yHQubUFuIw67uKkUeo=; b=HIKNzMTNNwFuj/sKVkq/NEJq5wWqB+YZmLpG3cyOq1Cw9nvSWfrAffnkkW2eyNRgzv DIdOzOty6pAUkrxidKxJmeEryEjq9rxtH0EFg8u/QtEAQzbUOV4Pc/Ky5Wyb2FKPjv3K WavEMo5jbP0Zszfnr1BhJ97Jlv0tSbSKyrnc/M5gs4+DrNsVA1B/rUj07RQ0QnslOOiq DCP1EX4uVkaPZcyGZ4ITyEzpr8zcb67b+DAH2kQQMKDwog3GlwNBuCUQfIpnLUNCy+gL 76l/qrhkcO3Pw7lJRIQnlPRhYrh3A8l7p5bx14mdHEXwUQPDvdOD1pGcrcAnpv8RLyL7 aJhg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1684829350; x=1687421350; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=DyLKHZ4ETQWRD0C327pl5xS+7yHQubUFuIw67uKkUeo=; b=BDb0o4eFBHnSFWyUZFB8irL/15+o+nbTDs3A30plfBz064xSnQiuFfRZbSgot0sITh 5d3kYUxfSRdIYwB87geEX5Nh6BZq0ll0dt+rvFTN+LTHztovIHmdHI0RVgy3Da7KYoOJ Hu9+gnaB1KqXdN6NX0TM3JwP2KGNjBT342wVVoNJJvupLJEHxDdCK1/sIeQlp+G3DsQ7 FyCnpgpp8TxkPuh0RjaLXn5WZPs+uhhQ5KYJaPhS9D/dr5BoyZQZfWh8qWp6MexTwO+i nPHPa32LIMlFqk2D2eNFHs+FHT+R9h/xkung8/CrR+EirUGpqHqX122MARUfxb3Iy14A 4QOg== X-Gm-Message-State: AC+VfDzBWTE4jPS8jjnzaqZ0GfNykEBCnATx5kwK23TqrGjbSIxcKVQy g7N6Gv32bOMwhGvUVcfV+dXV/mXUNLUwF4EQvvYV0g== X-Google-Smtp-Source: ACHHUZ4UPi8RCjk780pJ4fxObblOtqZ2fQWRpS7BZplU/D4z8rs9mwXCwGfmunRJYagAq0nRxjWH+g== X-Received: by 2002:adf:f711:0:b0:2ff:f37:9d0f with SMTP id r17-20020adff711000000b002ff0f379d0fmr9522832wrp.57.1684829350163; Tue, 23 May 2023 01:09:10 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id s4-20020a5d4244000000b00307bc4e39e5sm10105572wrr.117.2023.05.23.01.09.09 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 23 May 2023 01:09:09 -0700 (PDT) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Fix address manipulation issue in the tasking runtime Date: Tue, 23 May 2023 10:09:08 +0200 Message-Id: <20230523080908.1874670-1-poulhies@adacore.com> X-Mailer: git-send-email 2.40.0 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-13.2 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,GIT_PATCH_0,KAM_ASCII_DIVIDERS,RCVD_IN_DNSWL_NONE,SPF_HELO_NONE,SPF_PASS,TXREP,T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org List-Id: From: Eric Botcazou The implementation of task attributes in the runtime defines an atomic clone of System.Address, which is awkward for targets where addresses and pointers have a specific representation, so this change replaces that with a pragma Atomic_Components on the Attribute_Array type. gcc/ada/ * libgnarl/s-taskin.ads (Atomic_Address): Delete. (Attribute_Array): Add pragma Atomic_Components. (Ada_Task_Control_Block): Adjust default value of Attributes. * libgnarl/s-tasini.adb (Finalize_Attributes): Adjust type of local variable. * libgnarl/s-tataat.ads (Deallocator): Adjust type of parameter. (To_Attribute): Adjust source type. * libgnarl/a-tasatt.adb: Add clauses for System.Storage_Elements. (New_Attribute): Adjust return type. (Deallocate): Adjust type of parameter. (To_Real_Attribute): Adjust source type. (To_Address): Add target type. (To_Attribute): Adjust source type. (Fast_Path): Adjust tested type. (Finalize): Compare with Null_Address. (Reference): Likewise. (Reinitialize): Likewise. (Set_Value): Likewise. Add conversion to Integer_Address. (Value): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnarl/a-tasatt.adb | 51 ++++++++++++++++++----------------- gcc/ada/libgnarl/s-tasini.adb | 2 +- gcc/ada/libgnarl/s-taskin.ads | 9 +++---- gcc/ada/libgnarl/s-tataat.ads | 4 +-- 4 files changed, 33 insertions(+), 33 deletions(-) diff --git a/gcc/ada/libgnarl/a-tasatt.adb b/gcc/ada/libgnarl/a-tasatt.adb index fb3ca682f15..6111f2987a5 100644 --- a/gcc/ada/libgnarl/a-tasatt.adb +++ b/gcc/ada/libgnarl/a-tasatt.adb @@ -29,6 +29,7 @@ -- -- ------------------------------------------------------------------------------ +with System.Storage_Elements; with System.Tasking; with System.Tasking.Initialization; with System.Tasking.Task_Attributes; @@ -43,6 +44,7 @@ with Ada.Unchecked_Deallocation; package body Ada.Task_Attributes is use System, + System.Storage_Elements, System.Tasking.Initialization, System.Tasking, System.Tasking.Task_Attributes; @@ -75,34 +77,32 @@ package body Ada.Task_Attributes is -- System.Tasking.Task_Attributes.Attribute_Record and to allow unchecked -- conversions between Attribute_Access and Real_Attribute_Access. - function New_Attribute (Val : Attribute) return Atomic_Address; + function New_Attribute (Val : Attribute) return System.Address; -- Create a new Real_Attribute using Val, and return its address. The -- returned value can be converted via To_Real_Attribute. - procedure Deallocate (Ptr : Atomic_Address); + procedure Deallocate (Ptr : System.Address); -- Free memory associated with Ptr, a Real_Attribute_Access in reality function To_Real_Attribute is new - Ada.Unchecked_Conversion (Atomic_Address, Real_Attribute_Access); + Ada.Unchecked_Conversion (System.Address, Real_Attribute_Access); pragma Warnings (Off); -- Kill warning about possible size mismatch function To_Address is new - Ada.Unchecked_Conversion (Attribute, Atomic_Address); + Ada.Unchecked_Conversion (Attribute, System.Address); function To_Attribute is new - Ada.Unchecked_Conversion (Atomic_Address, Attribute); + Ada.Unchecked_Conversion (System.Address, Attribute); type Unsigned is mod 2 ** Integer'Size; - function To_Address is new - Ada.Unchecked_Conversion (Attribute, System.Address); function To_Unsigned is new Ada.Unchecked_Conversion (Attribute, Unsigned); pragma Warnings (On); function To_Address is new - Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address); + Ada.Unchecked_Conversion (Real_Attribute_Access, System.Address); pragma Warnings (Off); -- Kill warning about possible aliasing @@ -121,12 +121,12 @@ package body Ada.Task_Attributes is Fast_Path : constant Boolean := (Attribute'Size = Integer'Size - and then Attribute'Alignment <= Atomic_Address'Alignment + and then Attribute'Alignment <= System.Address'Alignment and then To_Unsigned (Initial_Value) = 0) or else (Attribute'Size = System.Address'Size - and then Attribute'Alignment <= Atomic_Address'Alignment - and then To_Address (Initial_Value) = System.Null_Address); - -- If the attribute fits in an Atomic_Address (both size and alignment) + and then Attribute'Alignment <= System.Address'Alignment + and then To_Address (Initial_Value) = Null_Address); + -- If the attribute fits in a System.Address (both size and alignment) -- and Initial_Value is 0 (or null), then we will map the attribute -- directly into ATCB.Attributes (Index), otherwise we will create -- a level of indirection and instead use Attributes (Index) as a @@ -153,11 +153,11 @@ package body Ada.Task_Attributes is while C /= null loop STPO.Write_Lock (C); - if C.Attributes (Index) /= 0 + if C.Attributes (Index) /= Null_Address and then Require_Finalization (Index) then Deallocate (C.Attributes (Index)); - C.Attributes (Index) := 0; + C.Attributes (Index) := Null_Address; end if; STPO.Unlock (C); @@ -173,7 +173,7 @@ package body Ada.Task_Attributes is -- Deallocate -- ---------------- - procedure Deallocate (Ptr : Atomic_Address) is + procedure Deallocate (Ptr : System.Address) is Obj : Real_Attribute_Access := To_Real_Attribute (Ptr); begin Free (Obj); @@ -183,7 +183,7 @@ package body Ada.Task_Attributes is -- New_Attribute -- ------------------- - function New_Attribute (Val : Attribute) return Atomic_Address is + function New_Attribute (Val : Attribute) return System.Address is Tmp : Real_Attribute_Access; begin Tmp := new Real_Attribute'(Free => Deallocate'Unrestricted_Access, @@ -223,7 +223,7 @@ package body Ada.Task_Attributes is Self_Id := STPO.Self; Task_Lock (Self_Id); - if TT.Attributes (Index) = 0 then + if TT.Attributes (Index) = Null_Address then TT.Attributes (Index) := New_Attribute (Initial_Value); end if; @@ -266,11 +266,11 @@ package body Ada.Task_Attributes is Task_Lock (Self_Id); declare - Attr : Atomic_Address renames TT.Attributes (Index); + Attr : System.Address renames TT.Attributes (Index); begin - if Attr /= 0 then + if Attr /= Null_Address then Deallocate (Attr); - Attr := 0; + Attr := Null_Address; end if; end; @@ -304,7 +304,8 @@ package body Ada.Task_Attributes is -- No finalization needed, simply set to Val if Attribute'Size = Integer'Size then - TT.Attributes (Index) := Atomic_Address (To_Unsigned (Val)); + TT.Attributes (Index) := + To_Address (Integer_Address (To_Unsigned (Val))); else TT.Attributes (Index) := To_Address (Val); end if; @@ -314,10 +315,10 @@ package body Ada.Task_Attributes is Task_Lock (Self_Id); declare - Attr : Atomic_Address renames TT.Attributes (Index); + Attr : System.Address renames TT.Attributes (Index); begin - if Attr /= 0 then + if Attr /= Null_Address then Deallocate (Attr); end if; @@ -357,10 +358,10 @@ package body Ada.Task_Attributes is Task_Lock (Self_Id); declare - Attr : Atomic_Address renames TT.Attributes (Index); + Attr : System.Address renames TT.Attributes (Index); begin - if Attr = 0 then + if Attr = Null_Address then Task_Unlock (Self_Id); return Initial_Value; diff --git a/gcc/ada/libgnarl/s-tasini.adb b/gcc/ada/libgnarl/s-tasini.adb index 24f4ba2085a..2000543ee2b 100644 --- a/gcc/ada/libgnarl/s-tasini.adb +++ b/gcc/ada/libgnarl/s-tasini.adb @@ -758,7 +758,7 @@ package body System.Tasking.Initialization is ------------------------- procedure Finalize_Attributes (T : Task_Id) is - Attr : Atomic_Address; + Attr : System.Address; begin for J in T.Attributes'Range loop diff --git a/gcc/ada/libgnarl/s-taskin.ads b/gcc/ada/libgnarl/s-taskin.ads index 47c5ca25a03..5aa3e37a904 100644 --- a/gcc/ada/libgnarl/s-taskin.ads +++ b/gcc/ada/libgnarl/s-taskin.ads @@ -958,11 +958,10 @@ package System.Tasking is type Entry_Call_Array is array (ATC_Level_Index) of aliased Entry_Call_Record; - type Atomic_Address is mod Memory_Size; - pragma Atomic (Atomic_Address); type Attribute_Array is - array (1 .. Parameters.Max_Attribute_Count) of Atomic_Address; - -- Array of task attributes. The value (Atomic_Address) will either be + array (1 .. Parameters.Max_Attribute_Count) of System.Address; + pragma Atomic_Components (Attribute_Array); + -- Array of task attributes. The value (System.Address) will either be -- converted to a task attribute if it fits, or to a pointer to a record -- by Ada.Task_Attributes. @@ -1157,7 +1156,7 @@ package System.Tasking is -- non-terminated task so that the associated storage is automatically -- reclaimed when the task terminates. - Attributes : Attribute_Array := [others => 0]; + Attributes : Attribute_Array := [others => Null_Address]; -- Task attributes -- IMPORTANT Note: the Entry_Queues field is last for efficiency of diff --git a/gcc/ada/libgnarl/s-tataat.ads b/gcc/ada/libgnarl/s-tataat.ads index 002a7cec1fe..e6d597cf907 100644 --- a/gcc/ada/libgnarl/s-tataat.ads +++ b/gcc/ada/libgnarl/s-tataat.ads @@ -35,7 +35,7 @@ with Ada.Unchecked_Conversion; package System.Tasking.Task_Attributes is - type Deallocator is access procedure (Ptr : Atomic_Address); + type Deallocator is access procedure (Ptr : System.Address); pragma Favor_Top_Level (Deallocator); type Attribute_Record is record @@ -48,7 +48,7 @@ package System.Tasking.Task_Attributes is pragma No_Strict_Aliasing (Attribute_Access); function To_Attribute is new - Ada.Unchecked_Conversion (Atomic_Address, Attribute_Access); + Ada.Unchecked_Conversion (System.Address, Attribute_Access); function Next_Index (Require_Finalization : Boolean) return Integer; -- Return the next attribute index available. Require_Finalization is True -- 2.40.0