From patchwork Fri Aug 2 07:11:19 2024 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: 95157 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 7B5B53860008 for ; Fri, 2 Aug 2024 07:13:26 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42b.google.com (mail-wr1-x42b.google.com [IPv6:2a00:1450:4864:20::42b]) by sourceware.org (Postfix) with ESMTPS id DD36B385DDF9 for ; Fri, 2 Aug 2024 07:12:24 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org DD36B385DDF9 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine 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 DD36B385DDF9 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::42b ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1722582751; cv=none; b=C0JU+kfI7SnAWy6HCKpgiyHDFm/hMFMfwNi0V9+8zJJ0EjzAxMvv38Ln2w8zzGC1swb6/HXlBt6TcT9Ons8KsHXeKOBwHK3KAHwihxuuexRI+ChcNcxHTU7vyNbO3TURCUVqFjh2YJnRaTHr0vQMt5Y41WXx2UedsUjr+S0rAIU= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1722582751; c=relaxed/simple; bh=kidiAKX7enstUeW/GE2MiaTX17mKlFD+9fe+IrRFTMk=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=dTsMCZyvUPaeLFw3/V/+lQ1OgGHfWT3ggeptfjCO7oUwYKo9tc/Nd06RKv5ZV+K+aeXyLGYqlKOmTF6dfYSwKIcN5WrKI4na6DGGVaVeaV1TbYD/2XODwJ9RDs2ET4qvWA/SJhAUPnYBTq3yfCMmVZkOBkdSKHQ07pUJnqxSE/Q= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x42b.google.com with SMTP id ffacd0b85a97d-36865a516f1so5383102f8f.0 for ; Fri, 02 Aug 2024 00:12:24 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1722582743; x=1723187543; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=6JJPW50X8MBBczZ2qm+D3mnieIFl5iz+nBqPjZ3/wZM=; b=V1pdKtZI8hnbsT/xRAPLRjq+AP0ZVUyAWs5VuyCIsJaBCA7HVbIhQ2dNdQxjYzbAiz OmSUOLFijDknbH4Hzyl2c+yjSR7pWjdJa82yTFSBOHUqZQobzKKm7G4DHCoduuWgQ7Fm 95qbGnflna78/Ez7pu0tw7avcEkylp1bzDxl4FoDsrBWoY9Ji7F5JcdAj6bxjzZ6l0im Z7z36JRU4CPmnIGJRdgjY0Rqi+f94eIFPuicZbUqt1mSm9lzRfCBtPhE0JW88z25c9Uz TQB0ERtCcT+03MnF3ontoIil6zUhTt6FqHyGEh4dyLm0L0HXqMon8zB03EtTpUqaV00d PWBg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1722582743; x=1723187543; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=6JJPW50X8MBBczZ2qm+D3mnieIFl5iz+nBqPjZ3/wZM=; b=pfmSOiKBUnxbiQiEYdxxO2tU/1J1GV2/4XXqmsQP6Iyttj+Uct3QKKPaTv7K1UQuSF oJBVu9wrfqmBjhsfS44HI7jxoRrk2ld7gBphPfCKOacExJpLudsmajSUN4Y04SJTg6tA 9opqtQ6FeJPCf2glG2oddvB8k0NnSaDD5KoZCeIsno0gwBL/CYxi7A6bVEBnlg3gWiHk z8HNCJ2gJFHK3V8FinGF5gHpVHirQlIGknp+gM7QcTEGeB1nMKvBWH9XmkLfSjbXnUPw mEd79V+11Z2QUh3GBdKFs4IZNcc+u6IzPb2o4Fks4eQSDrm/duuuMg6DW3whgWX0RstP O57Q== X-Gm-Message-State: AOJu0YzUmF4c1R9hNKf9Dss4Al7ywU9OMS7Rv8hXPnjtr9Ja9b6YqlPW fbaAOS/HoWh7kHNe8DYNDem5pkjbOovoPQDV1OgqmtSmHHKVwa7WMb57soghMWiw3Gi7ltpaONX b2g== X-Google-Smtp-Source: AGHT+IG4ouf6rMCZr5/d1UoiM8hM96y55JRRjGZpaIUUUF5vN0zchTQD0v2udCR6+0TNegrx7jZQqA== X-Received: by 2002:a05:6000:1a8f:b0:368:3384:e9da with SMTP id ffacd0b85a97d-36bbc1ddfdfmr1758383f8f.62.1722582742947; Fri, 02 Aug 2024 00:12:22 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:b6aa:4751:9ea1:da1e]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-36bbd059932sm1195770f8f.69.2024.08.02.00.12.22 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 02 Aug 2024 00:12:22 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 02/26] ada: Fix crash on expression function returning tagged type in nested package Date: Fri, 2 Aug 2024 09:11:19 +0200 Message-ID: <20240802071210.413366-2-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240802071210.413366-1-poulhies@adacore.com> References: <20240802071210.413366-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.3 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 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 This happens when the expression is a reference to a formal parameter of the function, or a conditional expression with such a reference as one of its dependent expressions, because the RM 6.5(8/5) subclause prescribes a tag reassignment in this case, which requires freezing the tagged type in the GNAT freezing model, although the language says there is no freezing. In other words, it's another occurrence of the discrepancy between this model tailored to Ada 95 and the freezing rules introduced in Ada 2012, that is papered over by Should_Freeze_Type and the associated processing. gcc/ada/ * exp_util.ads (Is_Conversion_Or_Reference_To_Formal): New function declaration. * exp_util.adb (Is_Conversion_Or_Reference_To_Formal): New function body. * exp_ch6.adb (Expand_Simple_Function_Return): Call the predicate Is_Conversion_Or_Reference_To_Formal in order to decide whether a tag check or reassignment is needed. * freeze.adb (Should_Freeze_Type): Move declaration and body to the appropriate places. Also return True for tagged results subject to the expansion done in Expand_Simple_Function_Return that is guarded by the predicate Is_Conversion_Or_Reference_To_Formal. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch6.adb | 9 +-- gcc/ada/exp_util.adb | 16 ++++ gcc/ada/exp_util.ads | 4 + gcc/ada/freeze.adb | 180 ++++++++++++++++++++++++++----------------- 4 files changed, 130 insertions(+), 79 deletions(-) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 548589284e2..9c182b2c6b4 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6989,14 +6989,7 @@ package body Exp_Ch6 is if Present (Utyp) and then Is_Tagged_Type (Utyp) and then not Is_Class_Wide_Type (Utyp) - and then (Nkind (Exp) in - N_Type_Conversion | N_Unchecked_Type_Conversion - or else (Nkind (Exp) = N_Explicit_Dereference - and then Nkind (Prefix (Exp)) in - N_Type_Conversion | - N_Unchecked_Type_Conversion) - or else (Is_Entity_Name (Exp) - and then Is_Formal (Entity (Exp)))) + and then Is_Conversion_Or_Reference_To_Formal (Exp) then -- When the return type is limited, perform a check that the tag of -- the result is the same as the tag of the return type. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index de096ea752a..c5d3af7545e 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -8560,6 +8560,22 @@ package body Exp_Util is end if; end Is_Captured_Function_Call; + ------------------------------------------ + -- Is_Conversion_Or_Reference_To_Formal -- + ------------------------------------------ + + function Is_Conversion_Or_Reference_To_Formal (N : Node_Id) return Boolean + is + begin + return Nkind (N) in N_Type_Conversion | N_Unchecked_Type_Conversion + or else (Nkind (N) = N_Explicit_Dereference + and then Nkind (Prefix (N)) in N_Type_Conversion + | N_Unchecked_Type_Conversion) + or else (Is_Entity_Name (N) + and then Present (Entity (N)) + and then Is_Formal (Entity (N))); + end Is_Conversion_Or_Reference_To_Formal; + ------------------------------ -- Is_Finalizable_Transient -- ------------------------------ diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index c772d411bcf..7fbbe5fc9fd 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -769,6 +769,10 @@ package Exp_Util is -- Rnn : constant Ann := Func (...)'reference; -- Rnn.all + function Is_Conversion_Or_Reference_To_Formal (N : Node_Id) return Boolean; + -- Return True if N is a type conversion, or a dereference thereof, or a + -- reference to a formal parameter. + function Is_Finalizable_Transient (Decl : Node_Id; N : Node_Id) return Boolean; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index cf7a22efcae..c8d20d020c7 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -185,77 +185,6 @@ package body Freeze is -- the designated type. Otherwise freezing the access type does not freeze -- the designated type. - function Should_Freeze_Type - (Typ : Entity_Id; E : Entity_Id; N : Node_Id) return Boolean; - -- If Typ is in the current scope, then return True. - -- N is a node whose source location corresponds to the freeze point. - -- ??? Expression functions (represented by E) shouldn't freeze types in - -- general, but our current expansion and freezing model requires an early - -- freezing when the dispatch table is needed or when building an aggregate - -- with a subtype of Typ, so return True also in this case. - -- Note that expression function completions do freeze and are - -- handled in Sem_Ch6.Analyze_Expression_Function. - - ------------------------ - -- Should_Freeze_Type -- - ------------------------ - - function Should_Freeze_Type - (Typ : Entity_Id; E : Entity_Id; N : Node_Id) return Boolean - is - function Is_Dispatching_Call_Or_Aggregate - (N : Node_Id) return Traverse_Result; - -- Return Abandon if N is a dispatching call to a subprogram - -- declared in the same scope as Typ or an aggregate whose type - -- is Typ. - - -------------------------------------- - -- Is_Dispatching_Call_Or_Aggregate -- - -------------------------------------- - - function Is_Dispatching_Call_Or_Aggregate - (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Function_Call - and then Present (Controlling_Argument (N)) - and then Scope (Entity (Original_Node (Name (N)))) - = Scope (Typ) - then - return Abandon; - elsif Nkind (N) in N_Aggregate - | N_Extension_Aggregate - | N_Delta_Aggregate - and then Base_Type (Etype (N)) = Base_Type (Typ) - then - return Abandon; - else - return OK; - end if; - end Is_Dispatching_Call_Or_Aggregate; - - ------------------------- - -- Need_Dispatch_Table -- - ------------------------- - - function Need_Dispatch_Table is new - Traverse_Func (Is_Dispatching_Call_Or_Aggregate); - -- Return Abandon if the input expression requires access to - -- Typ's dispatch table. - - Decl : constant Node_Id := - (if No (E) then E else Original_Node (Unit_Declaration_Node (E))); - - -- Start of processing for Should_Freeze_Type - - begin - return Within_Scope (Typ, Current_Scope) - or else (Nkind (N) = N_Subprogram_Renaming_Declaration - and then Present (Corresponding_Formal_Spec (N))) - or else (Present (Decl) - and then Nkind (Decl) = N_Expression_Function - and then Need_Dispatch_Table (Expression (Decl)) = Abandon); - end Should_Freeze_Type; - procedure Process_Default_Expressions (E : Entity_Id; After : in out Node_Id); @@ -282,6 +211,17 @@ package body Freeze is -- attribute definition clause occurs, then these two flags are reset in -- any case, so call will have no effect. + function Should_Freeze_Type + (Typ : Entity_Id; + E : Entity_Id; + N : Node_Id) return Boolean; + -- True if Typ should be frozen when the profile of E is being frozen at N. + + -- ??? Expression functions that are not completions shouldn't freeze types + -- but our current expansion and freezing model requires an early freezing + -- when the tag of Typ is needed or for an aggregate with a subtype of Typ, + -- so we return True in these cases. + procedure Undelay_Type (T : Entity_Id); -- T is a type of a component that we know to be an Itype. We don't want -- this to have a Freeze_Node, so ensure it doesn't. Do the same for any @@ -10592,6 +10532,104 @@ package body Freeze is end if; end Set_SSO_From_Default; + ------------------------ + -- Should_Freeze_Type -- + ------------------------ + + function Should_Freeze_Type + (Typ : Entity_Id; + E : Entity_Id; + N : Node_Id) return Boolean + is + Decl : constant Node_Id := Original_Node (Unit_Declaration_Node (E)); + + function Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate + (N : Node_Id) return Traverse_Result; + -- Return Abandon if N is a dispatching call to a subprogram + -- declared in the same scope as Typ, or a tagged result that + -- needs specific expansion, or an aggregate whose type is Typ. + + function Check_Freezing is new + Traverse_Func (Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate); + -- Return Abandon if the input expression requires freezing Typ + + function Within_Simple_Return_Statement (N : Node_Id) return Boolean; + -- Determine whether N is the expression of a simple return statement, + -- or the dependent expression of a conditional expression which is + -- the expression of a simple return statement, including recursively. + + ------------------------------------------------------- + -- Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate -- + ------------------------------------------------------- + + function Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate + (N : Node_Id) return Traverse_Result + is + begin + if Nkind (N) = N_Function_Call + and then Present (Controlling_Argument (N)) + and then Scope (Entity (Original_Node (Name (N)))) = Scope (Typ) + then + return Abandon; + + -- The expansion done in Expand_Simple_Function_Return will assign + -- the tag to the result in this case. + + elsif Is_Conversion_Or_Reference_To_Formal (N) + and then Within_Simple_Return_Statement (N) + and then Etype (N) = Typ + and then Is_Tagged_Type (Typ) + and then not Is_Class_Wide_Type (Typ) + then + return Abandon; + + elsif Nkind (N) in N_Aggregate + | N_Delta_Aggregate + | N_Extension_Aggregate + and then Base_Type (Etype (N)) = Base_Type (Typ) + then + return Abandon; + + else + return OK; + end if; + end Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate; + + ------------------------------------ + -- Within_Simple_Return_Statement -- + ------------------------------------ + + function Within_Simple_Return_Statement (N : Node_Id) return Boolean is + Par : constant Node_Id := Parent (N); + + begin + if Nkind (Par) = N_Simple_Return_Statement then + return True; + + elsif Nkind (Par) = N_Case_Expression_Alternative then + return Within_Simple_Return_Statement (Parent (Par)); + + elsif Nkind (Par) = N_If_Expression + and then N /= First (Expressions (Par)) + then + return Within_Simple_Return_Statement (Par); + + else + return False; + end if; + end Within_Simple_Return_Statement; + + -- Start of processing for Should_Freeze_Type + + begin + return Within_Scope (Typ, Current_Scope) + or else (Nkind (N) = N_Subprogram_Renaming_Declaration + and then Present (Corresponding_Formal_Spec (N))) + or else (Present (Decl) + and then Nkind (Decl) = N_Expression_Function + and then Check_Freezing (Expression (Decl)) = Abandon); + end Should_Freeze_Type; + ------------------ -- Undelay_Type -- ------------------