From patchwork Thu Nov 30 10:19:19 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 81018 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id DE7CE382CD75 for ; Thu, 30 Nov 2023 10:21:11 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x330.google.com (mail-wm1-x330.google.com [IPv6:2a00:1450:4864:20::330]) by sourceware.org (Postfix) with ESMTPS id 3DA373861885 for ; Thu, 30 Nov 2023 10:19:22 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 3DA373861885 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 3DA373861885 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::330 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1701339565; cv=none; b=QLra55W8QREol66sSmuwzIDC/Vdn+NpfWHxWu9p1s+5dc+vn8thTG/3pRj/Ic6E7F6Es7sDLWxq4fD8/DHXYOO6x3EhMMDNS4JTmu2DIeC0EX6VEkhPp75zagXb5TJXIiovzdbMhi+XiIK8pir8MDzBVkvhv17lyq6iMPqPGBuw= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1701339565; c=relaxed/simple; bh=VEhZQBx2v7TFSDvQHI++71orUnZZ52dbydii7QXJJBw=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=PLCX6jC0U3tCY74kbq6GvGmoqWnWFGxG+eynO2w3uJhrknWSRG6AWdK0Zg8mzk3Gz++huBNjKhVIKK6z3Q5dFTnQy9DorYzkntOucKDRtuIGZ2KjI5oMJBoTvNQ/LjySasC26vUWVgSTWqV542L32gG07v12wJ2O4jXbBXfauQY= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x330.google.com with SMTP id 5b1f17b1804b1-40b57fa7a85so3108515e9.1 for ; Thu, 30 Nov 2023 02:19:22 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1701339561; x=1701944361; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=7jaletnRJIG7kH3uehP3VWSyQCcSxJdE1WxHMZ7a2BY=; b=JY1svYaQhZ7RE8qw7MVNbGMcxUvRDvEhEaZ2xW6LAI4I8hCcpbgfzPIbkskCIiVldx a3QXkqs5+6zL+VQAsDLZgVGm+SRJ7e3wX80JqAOnxkS+6aPu1mQl0nk2EUWwqNQOhFAb Q57BFZRz9us3lCVSO2z0MyBAmvRsndacAZZRMKkPzfCKI2+UVEURLB79sr4HfRwS4CTe 6H62FzkLvMH5+NENOpOrm+UsdAy/UuD+Icv6UDm7/DjhaWdjgvcxxuQue7WPFjxrxpTp lnOk3v1tvVzEPF2TkUh7BXFF3Rp4HI6aRFsWtQYkUYjCYPVfJUzZYi+rQ7EyQpQ8s3Wi +wWQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1701339561; x=1701944361; 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=7jaletnRJIG7kH3uehP3VWSyQCcSxJdE1WxHMZ7a2BY=; b=vB9Ttqyng5VbSr6PZPog2e+mFgF3ZyrQO2lZsvel4vV441F8rF6Attihyewy5iPDPb /9DXzivdhBgh03JmXx5QpmXGA5cH4Jy8bpneiNdxvFAfjg58tS9h90KzVcCsk892fwAJ sK6biB0mb0hLOVk1LYP5cW41nc3QFrfaZ+WOhdSa1jfZdqMeufNVPM5dzwHpuesQyMZ1 jpkZdqImhDpB6YB0fSiaH6ddX3wC13hv6nQrwfbE78RI5Zb+wEBihM+ufK5f1n6UX6FM OJlaomi9UkSM1hrD4AWrw635LzOVVeYN0CKz5cT8WZCe/rhBf96slOWL2YBGODv9CEu2 uIUw== X-Gm-Message-State: AOJu0YzDJUZzYy0qWpzUJAGavHycBFEWxS04Vv7khnejrHnfeTmC7y4O Gh5K2HDzdlRSyC31ez1wa4RRLsdEkS9XXVLEwfLcZA== X-Google-Smtp-Source: AGHT+IFuQf5GdaT6PmA9DPlkKQCXDzZVc6F4z0uhqh3zOoBbai8KmCARu6wDev1bJTwD2Y68W1e2DQ== X-Received: by 2002:a05:600c:1da5:b0:40b:50bf:e6df with SMTP id p37-20020a05600c1da500b0040b50bfe6dfmr4718208wms.10.1701339560898; Thu, 30 Nov 2023 02:19:20 -0800 (PST) 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 bg5-20020a05600c3c8500b0040b4562ee20sm2212467wmb.0.2023.11.30.02.19.20 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 30 Nov 2023 02:19:20 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Rework fix for wrong finalization of qualified aggregate in allocator Date: Thu, 30 Nov 2023 11:19:19 +0100 Message-ID: <20231130101919.3094562-1-poulhies@adacore.com> X-Mailer: git-send-email 2.42.0 MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, 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 X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org From: Eric Botcazou The problem is that there is no easy method to insert an action after an arbitrary node in the tree, so the original fix does not correctly work when the allocator is nested in another expression. Therefore this moves the burden of the insertion from Apply_Predicate_Check to Expand_Allocator_Expression and restricts the new processing to the case where it is really required. gcc/ada/ * checks.ads (Apply_Predicate_Check): Add Deref boolean parameter. * checks.adb (Apply_Predicate_Check): Revert latest change. Use Loc local variable to hold the source location. Use a common code path for the generic processing and make a dereference if Deref is True. * exp_ch4.adb (Expand_Allocator_Expression): Compute Aggr_In_Place earlier. If it is true, do not call Apply_Predicate_Check on the expression on entry but on the temporary on exit with a dereference. * sem_res.adb (Resolve_Actuals): Add explicit parameter association in call to Apply_Predicate_Check. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/checks.adb | 87 ++++++++++++++++++++------------------------- gcc/ada/checks.ads | 13 +++---- gcc/ada/exp_ch4.adb | 24 +++++++++---- gcc/ada/sem_res.adb | 2 +- 4 files changed, 63 insertions(+), 63 deletions(-) diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 14e82f2adc6..d59d44fd6ab 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2720,15 +2720,20 @@ package body Checks is --------------------------- procedure Apply_Predicate_Check - (N : Node_Id; - Typ : Entity_Id; - Fun : Entity_Id := Empty) + (N : Node_Id; + Typ : Entity_Id; + Deref : Boolean := False; + Fun : Entity_Id := Empty) is - Par : Node_Id; - S : Entity_Id; + Loc : constant Source_Ptr := Sloc (N); + Check_Disabled : constant Boolean := + not Predicate_Enabled (Typ) + or else not Predicate_Check_In_Scope (N); + + Expr : Node_Id; + Par : Node_Id; + S : Entity_Id; - Check_Disabled : constant Boolean := not Predicate_Enabled (Typ) - or else not Predicate_Check_In_Scope (N); begin S := Current_Scope; while Present (S) and then not Is_Subprogram (S) loop @@ -2757,7 +2762,7 @@ package body Checks is if not Check_Disabled then Insert_Action (N, - Make_Raise_Storage_Error (Sloc (N), + Make_Raise_Storage_Error (Loc, Reason => SE_Infinite_Recursion)); return; end if; @@ -2824,19 +2829,9 @@ package body Checks is Par := Parent (Par); end if; - -- For an entity of the type, generate a call to the predicate - -- function, unless its type is an actual subtype, which is not - -- visible outside of the enclosing subprogram. - - if Is_Entity_Name (N) - and then not Is_Actual_Subtype (Typ) - then - Insert_Action (N, - Make_Predicate_Check - (Typ, New_Occurrence_Of (Entity (N), Sloc (N)))); - return; + -- Try to avoid creating a temporary if the expression is an aggregate - elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then + if Nkind (N) in N_Aggregate | N_Extension_Aggregate then -- If the expression is an aggregate in an assignment, apply the -- check to the LHS after the assignment, rather than create a @@ -2851,27 +2846,6 @@ package body Checks is (Typ, Duplicate_Subexpr (Name (Par)))); return; - -- Similarly, if the expression is a qualified aggregate in an - -- allocator, apply the check to the dereference of the access - -- value, rather than create a temporary. This is necessary for - -- inherently limited types, for which the temporary is illegal. - - elsif Nkind (Par) = N_Allocator then - declare - Deref : constant Node_Id := - Make_Explicit_Dereference (Sloc (N), - Prefix => Duplicate_Subexpr (Par)); - - begin - -- This is required by Predicate_Check_In_Scope ??? - - Preserve_Comes_From_Source (Deref, N); - - Insert_Action_After (Parent (Par), - Make_Predicate_Check (Typ, Deref)); - return; - end; - -- Similarly, if the expression is an aggregate in an object -- declaration, apply it to the object after the declaration. @@ -2892,21 +2866,36 @@ package body Checks is then Insert_Action_After (Par, Make_Predicate_Check (Typ, - New_Occurrence_Of (Defining_Identifier (Par), Sloc (N)))); + New_Occurrence_Of (Defining_Identifier (Par), Loc))); return; end if; end if; end if; - -- If the expression is not an entity it may have side effects, - -- and the following call will create an object declaration for - -- it. We disable checks during its analysis, to prevent an - -- infinite recursion. + -- For an entity of the type, generate a call to the predicate + -- function, unless its type is an actual subtype, which is not + -- visible outside of the enclosing subprogram. - Insert_Action (N, - Make_Predicate_Check - (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks); + if Is_Entity_Name (N) and then not Is_Actual_Subtype (Typ) then + Expr := New_Occurrence_Of (Entity (N), Loc); + + -- If the expression is not an entity, it may have side effects + + else + Expr := Duplicate_Subexpr (N); + end if; + + -- Make the dereference if requested + + if Deref then + Expr := Make_Explicit_Dereference (Loc, Prefix => Expr); + end if; + + -- Disable checks to prevent an infinite recursion + + Insert_Action + (N, Make_Predicate_Check (Typ, Expr), Suppress => All_Checks); end Apply_Predicate_Check; ----------------------- diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 64f0809dbea..8fd380283cc 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -256,13 +256,14 @@ package Checks is -- results. procedure Apply_Predicate_Check - (N : Node_Id; - Typ : Entity_Id; - Fun : Entity_Id := Empty); + (N : Node_Id; + Typ : Entity_Id; + Deref : Boolean := False; + Fun : Entity_Id := Empty); -- N is an expression to which a predicate check may need to be applied for - -- Typ, if Typ has a predicate function. When N is an actual in a call, Fun - -- is the function being called, which is used to generate a better warning - -- if the call leads to an infinite recursion. + -- Typ if Typ has a predicate function, after dereference if Deref is True. + -- When N is an actual in a call, Fun is the function being called, which + -- is used to generate a warning if the call leads to infinite recursion. procedure Apply_Type_Conversion_Checks (N : Node_Id); -- N is an N_Type_Conversion node. A type conversion actually involves diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e708ed350d1..99be96d3ab7 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -563,8 +563,6 @@ package body Exp_Ch4 is DesigT : constant Entity_Id := Designated_Type (PtrT); Special_Return : constant Boolean := For_Special_Return_Object (N); - -- Local variables - Adj_Call : Node_Id; Aggr_In_Place : Boolean; Node : Node_Id; @@ -577,8 +575,6 @@ package body Exp_Ch4 is TagR : Node_Id := Empty; -- Target reference for tag assignment - -- Start of processing for Expand_Allocator_Expression - begin -- Handle call to C++ constructor @@ -598,7 +594,15 @@ package body Exp_Ch4 is Apply_Constraint_Check (Exp, T, No_Sliding => True); - Apply_Predicate_Check (Exp, T); + Aggr_In_Place := Is_Delayed_Aggregate (Exp); + + -- If the expression is an aggregate to be built in place, then we need + -- to delay applying predicate checks, because this would result in the + -- creation of a temporary, which is illegal for limited types, + + if not Aggr_In_Place then + Apply_Predicate_Check (Exp, T); + end if; -- Check that any anonymous access discriminants are suitable -- for use in an allocator. @@ -659,8 +663,6 @@ package body Exp_Ch4 is return; end if; - Aggr_In_Place := Is_Delayed_Aggregate (Exp); - -- Case of tagged type or type requiring finalization if Is_Tagged_Type (T) or else Needs_Finalization (T) then @@ -972,6 +974,10 @@ package body Exp_Ch4 is Rewrite (N, New_Occurrence_Of (Temp, Loc)); Analyze_And_Resolve (N, PtrT); + if Aggr_In_Place then + Apply_Predicate_Check (N, T, Deref => True); + end if; + -- Ada 2005 (AI-251): Displace the pointer to reference the record -- component containing the secondary dispatch table of the interface -- type. @@ -1012,6 +1018,10 @@ package body Exp_Ch4 is Rewrite (N, New_Occurrence_Of (Temp, Loc)); Analyze_And_Resolve (N, PtrT); + if Aggr_In_Place then + Apply_Predicate_Check (N, T, Deref => True); + end if; + elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then Install_Null_Excluding_Check (Exp); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 8e5d351141d..c684075219b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4735,7 +4735,7 @@ package body Sem_Res is -- leads to an infinite recursion. if Predicate_Tests_On_Arguments (Nam) then - Apply_Predicate_Check (A, F_Typ, Nam); + Apply_Predicate_Check (A, F_Typ, Fun => Nam); end if; -- Apply required constraint checks