From patchwork Tue Jul 5 08:30:00 2022 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: 1652350 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: bilbo.ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=D/+kZKnI; dkim-atps=neutral Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Received: from sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (2048 bits) server-digest SHA256) (No client certificate requested) by bilbo.ozlabs.org (Postfix) with ESMTPS id 4LcbZ86J7Yz9s1l for ; Tue, 5 Jul 2022 18:34:24 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id CDE1E383603A for ; Tue, 5 Jul 2022 08:34:22 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org CDE1E383603A DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1657010062; bh=VjlCNN70dd29QcOLLcm1qOFm+uCWA6cktUq/Vt1PCOA=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=D/+kZKnI73Ijjlx/59XDZkgdhpmhlm6j8veVe8z+vVI6GVMTrIb8idNi+ztmS+4lG Z+o83dQ77DN1PRzE8gmRz6h6lUKrSNQzBdqL+y1rFCBwwAXcOPLuIh2RbJNMZTedhU YAjRgmoCXyXfysOsnJrcCN9PGLV3iH7DeSTjZ98Y= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x431.google.com (mail-wr1-x431.google.com [IPv6:2a00:1450:4864:20::431]) by sourceware.org (Postfix) with ESMTPS id DA098385829C for ; Tue, 5 Jul 2022 08:30:02 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org DA098385829C Received: by mail-wr1-x431.google.com with SMTP id o4so16447911wrh.3 for ; Tue, 05 Jul 2022 01:30:02 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=VjlCNN70dd29QcOLLcm1qOFm+uCWA6cktUq/Vt1PCOA=; b=vqiK2D8niZMJBJYIta3FPehqAk7J4S/pomOArbG4PIkOALxtKnCOxcwS7eyvsNG1xG qnOrEWaZE2iA5EgYalnODgFfs+ebfUZ3y24syAnucRINHhrgkIDP7x+x9ao/st3nAAUp iQDE7r3crIkplpGYxvLIaCIYDeZKgDKwD1yjlLJot9YYE55cUSu16cVrsw+xMSJ0JkmR qBf9BxQ+jmt8z4txhvXfFZ+Djnbky5l2HDUIfBptq76pwmYrpu8kGnPbLAAN4JGztOa3 L/ZOgZgfN4Pa6SX04xJYAWtvrc96NtmZ19BAA/rDN8rG0ZX7tlPiN7N0hsA6U9hkahGb PrIQ== X-Gm-Message-State: AJIora8kOzV6Ai9q3/tQH/u5gpBsdYh1KQVhoYyP7f6kArYK+MCZAWPo d1uCNI3s64zuYjRg0uunhuYoFwll99OiYw== X-Google-Smtp-Source: AGRyM1t+nLLNVatjwCX4FBkQz+68ut3jBSJs7+zzSngPwvPAOuVlc7NT7mywzk0t5lQoqutLTdM7/A== X-Received: by 2002:a05:6000:18d:b0:21d:3f5e:6d24 with SMTP id p13-20020a056000018d00b0021d3f5e6d24mr24684102wrx.150.1657009801624; Tue, 05 Jul 2022 01:30:01 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id q4-20020adff944000000b0021b956da1dcsm32276876wrr.113.2022.07.05.01.30.00 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 05 Jul 2022 01:30:00 -0700 (PDT) Date: Tue, 5 Jul 2022 08:30:00 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Misc cleanup related to finalization Message-ID: <20220705083000.GA3189855@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-12.8 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, WEIRD_QUOTING 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.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Bob Duff Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" This patch cleans up some code issues found while working on finalization, and adds some debugging aids. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch7.adb: Change two constants Is_Protected_Body and Is_Prot_Body to be Is_Protected_Subp_Body; these are not true for protected bodies, but for protected subprogram bodies. (Expand_Cleanup_Actions): No need to search for Activation_Chain_Entity; just use Activation_Chain_Entity. * sem_ch8.adb (Find_Direct_Name): Use Entyp constant. * atree.adb, atree.ads, atree.h, nlists.adb, nlists.ads (Parent): Provide nonoverloaded versions of Parent, so that they can be easily found in the debugger. * debug_a.adb, debug_a.ads: Clarify that we're talking about the -gnatda switch; switches are case sensitive. Print out the Chars field if appropriate, which makes it easier to find things in the output. (Debug_Output_Astring): Simplify. Also fix an off-by-one bug ("for I in Vbars'Length .." should have been "for I in Vbars'Length + 1 .."). Before, it was printing Debug_A_Depth + 1 '|' characters if Debug_A_Depth > Vbars'Length. diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -1966,7 +1966,7 @@ package body Atree is end if; end Paren_Count; - function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id is + function Node_Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id is begin pragma Assert (Present (N)); @@ -1975,7 +1975,7 @@ package body Atree is else return Node_Or_Entity_Id (Link (N)); end if; - end Parent; + end Node_Parent; ------------- -- Present -- @@ -2292,12 +2292,12 @@ package body Atree is -- Set_Parent -- ---------------- - procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is + procedure Set_Node_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is begin pragma Assert (Present (N)); pragma Assert (not In_List (N)); Set_Link (N, Union_Id (Val)); - end Set_Parent; + end Set_Node_Parent; ------------------------ -- Set_Reporting_Proc -- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -446,10 +446,15 @@ package Atree is -- Tests given Id for equality with the Empty node. This allows notations -- like "if No (Variant_Part)" as opposed to "if Variant_Part = Empty". - function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id; + function Node_Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id; + pragma Inline (Node_Parent); + function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id + renames Node_Parent; pragma Inline (Parent); -- Returns the parent of a node if the node is not a list member, or else -- the parent of the list containing the node if the node is a list member. + -- Parent has the same name as the one in Nlists; Node_Parent can be used + -- more easily in the debugger. function Paren_Count (N : Node_Id) return Nat; pragma Inline (Paren_Count); @@ -465,7 +470,10 @@ package Atree is -- Note that this routine is used only in very peculiar cases. In normal -- cases, the Original_Node link is set by calls to Rewrite. - procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id); + procedure Set_Node_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id); + pragma Inline (Set_Node_Parent); + procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) + renames Set_Node_Parent; pragma Inline (Set_Parent); procedure Set_Paren_Count (N : Node_Id; Val : Nat); diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -35,7 +35,7 @@ extern "C" { #endif -#define Parent atree__parent +#define Parent atree__node_parent extern Node_Id Parent (Node_Id); #define Original_Node atree__original_node diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb --- a/gcc/ada/debug_a.adb +++ b/gcc/ada/debug_a.adb @@ -25,6 +25,7 @@ with Atree; use Atree; with Debug; use Debug; +with Namet; use Namet; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinput; use Sinput; @@ -33,7 +34,7 @@ with Output; use Output; package body Debug_A is Debug_A_Depth : Natural := 0; - -- Output for the debug A flag is preceded by a sequence of vertical bar + -- Output for the -gnatda switch is preceded by a sequence of vertical bar -- characters corresponding to the recursion depth of the actions being -- recorded (analysis, expansion, resolution and evaluation of nodes) -- This variable records the depth. @@ -66,7 +67,7 @@ package body Debug_A is procedure Debug_A_Entry (S : String; N : Node_Id) is begin - -- Output debugging information if -gnatda flag set + -- Output debugging information if -gnatda switch set if Debug_Flag_A then Debug_Output_Astring; @@ -77,6 +78,19 @@ package body Debug_A is Write_Location (Sloc (N)); Write_Str (" "); Write_Str (Node_Kind'Image (Nkind (N))); + + -- Print the Chars field, if appropriate + + case Nkind (N) is + when N_Has_Chars => + Write_Str (" """); + if Present (Chars (N)) then + Write_Str (Get_Name_String (Chars (N))); + end if; + Write_Str (""""); + when others => null; + end case; + Write_Eol; end if; @@ -115,7 +129,7 @@ package body Debug_A is end if; end loop; - -- Output debugging information if -gnatda flag set + -- Output debugging information if -gnatda switch set if Debug_Flag_A then Debug_Output_Astring; @@ -132,18 +146,8 @@ package body Debug_A is -------------------------- procedure Debug_Output_Astring is - Vbars : constant String := "|||||||||||||||||||||||||"; begin - if Debug_A_Depth > Vbars'Length then - for I in Vbars'Length .. Debug_A_Depth loop - Write_Char ('|'); - end loop; - - Write_Str (Vbars); - - else - Write_Str (Vbars (1 .. Debug_A_Depth)); - end if; + Write_Str ((1 .. Debug_A_Depth => '|')); end Debug_Output_Astring; end Debug_A; diff --git a/gcc/ada/debug_a.ads b/gcc/ada/debug_a.ads --- a/gcc/ada/debug_a.ads +++ b/gcc/ada/debug_a.ads @@ -23,7 +23,7 @@ -- -- ------------------------------------------------------------------------------ --- This package contains data and subprograms to support the A debug switch +-- This package contains data and subprograms to support the -gnatda switch -- that is used to generate output showing what node is being analyzed, -- resolved, evaluated, or expanded. @@ -44,18 +44,18 @@ package Debug_A is -- Generates a message prefixed by a sequence of bars showing the nesting -- depth (depth increases by 1 for a Debug_A_Entry call and is decreased -- by the corresponding Debug_A_Exit call). Then the string is output - -- (analyzing, expanding etc), followed by the node number and its kind. - -- This output is generated only if the debug A flag is set. If the debug - -- A flag is not set, then no output is generated. This call also sets the - -- Node_Id value in Atree.Current_Error_Node in case a bomb occurs. This - -- is done unconditionally, whether or not the debug A flag is set. + -- (analyzing, expanding etc), followed by information about the node. + -- This output is generated only if the -gnatda switch is set. If that + -- switch is not set, then no output is generated. This call also sets the + -- Node_Id value in Atree.Current_Error_Node in case a bomb occurs. This is + -- done unconditionally, whether or not the switch is set. procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String); pragma Inline (Debug_A_Exit); -- Generates the corresponding termination message. The message is preceded -- by a sequence of bars, followed by the string S, the node number, and -- a trailing comment (e.g. " (already evaluated)"). This output is - -- generated only if the debug A flag is set. If the debug A flag is not + -- generated only if the -gnatda switch is set. If that switch is not -- set, then no output is generated. This call also resets the value in -- Atree.Current_Error_Node to what it was before the corresponding call -- to Debug_A_Entry. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -867,19 +867,16 @@ package body Exp_Ch7 is Additional_Cleanup : List_Id) return List_Id is Is_Asynchronous_Call : constant Boolean := - Nkind (N) = N_Block_Statement - and then Is_Asynchronous_Call_Block (N); - Is_Master : constant Boolean := - Nkind (N) /= N_Entry_Body - and then Is_Task_Master (N); - Is_Protected_Body : constant Boolean := - Nkind (N) = N_Subprogram_Body - and then Is_Protected_Subprogram_Body (N); - Is_Task_Allocation : constant Boolean := - Nkind (N) = N_Block_Statement - and then Is_Task_Allocation_Block (N); - Is_Task_Body : constant Boolean := - Nkind (Original_Node (N)) = N_Task_Body; + Nkind (N) = N_Block_Statement and then Is_Asynchronous_Call_Block (N); + Is_Master : constant Boolean := + Nkind (N) /= N_Entry_Body and then Is_Task_Master (N); + Is_Protected_Subp_Body : constant Boolean := + Nkind (N) = N_Subprogram_Body + and then Is_Protected_Subprogram_Body (N); + Is_Task_Allocation : constant Boolean := + Nkind (N) = N_Block_Statement and then Is_Task_Allocation_Block (N); + Is_Task_Body : constant Boolean := + Nkind (Original_Node (N)) = N_Task_Body; Loc : constant Source_Ptr := Sloc (N); Stmts : constant List_Id := New_List; @@ -905,7 +902,7 @@ package body Exp_Ch7 is -- NOTE: The generated code references _object, a parameter to the -- procedure. - elsif Is_Protected_Body then + elsif Is_Protected_Subp_Body then declare Spec : constant Node_Id := Parent (Corresponding_Spec (N)); Conc_Typ : Entity_Id := Empty; @@ -3695,9 +3692,9 @@ package body Exp_Ch7 is -------------------------- procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is - Is_Prot_Body : constant Boolean := - Nkind (N) = N_Subprogram_Body - and then Is_Protected_Subprogram_Body (N); + Is_Protected_Subp_Body : constant Boolean := + Nkind (N) = N_Subprogram_Body + and then Is_Protected_Subprogram_Body (N); -- Determine whether N denotes the protected version of a subprogram -- which belongs to a protected type. @@ -3733,7 +3730,7 @@ package body Exp_Ch7 is -- end; -- end Prot_SubpP; - if Is_Prot_Body then + if Is_Protected_Subp_Body then HSS := Handled_Statement_Sequence (Last (Statements (HSS))); end if; @@ -5745,24 +5742,12 @@ package body Exp_Ch7 is if Is_Task_Allocation then declare - Chain : constant Entity_Id := Activation_Chain_Entity (N); - Decl : Node_Id; - + Chain_Decl : constant N_Object_Declaration_Id := + Parent (Activation_Chain_Entity (N)); + pragma Assert (List_Containing (Chain_Decl) = Decls); begin - Decl := First (Decls); - while Nkind (Decl) /= N_Object_Declaration - or else Defining_Identifier (Decl) /= Chain - loop - Next (Decl); - - -- A task allocation block should always include a _chain - -- declaration. - - pragma Assert (Present (Decl)); - end loop; - - Remove (Decl); - Prepend_To (New_Decls, Decl); + Remove (Chain_Decl); + Prepend_To (New_Decls, Chain_Decl); end; end if; diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -1013,12 +1013,12 @@ package body Nlists is -- Parent -- ------------ - function Parent (List : List_Id) return Node_Or_Entity_Id is + function List_Parent (List : List_Id) return Node_Or_Entity_Id is begin pragma Assert (Present (List)); pragma Assert (List <= Lists.Last); return Lists.Table (List).Parent; - end Parent; + end List_Parent; ---------- -- Pick -- @@ -1442,12 +1442,12 @@ package body Nlists is -- Set_Parent -- ---------------- - procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is + procedure Set_List_Parent (List : List_Id; Node : Node_Or_Entity_Id) is begin pragma Assert (not Locked); pragma Assert (List <= Lists.Last); Lists.Table (List).Parent := Node; - end Set_Parent; + end Set_List_Parent; -------------- -- Set_Prev -- diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.ads @@ -348,13 +348,21 @@ package Nlists is -- Called to unlock list contents when assertions are enabled; if -- assertions are not enabled calling this subprogram has no effect. - function Parent (List : List_Id) return Node_Or_Entity_Id; + function List_Parent (List : List_Id) return Node_Or_Entity_Id; + pragma Inline (List_Parent); + function Parent (List : List_Id) return Node_Or_Entity_Id + renames List_Parent; pragma Inline (Parent); -- Node lists may have a parent in the same way as a node. The function -- accesses the Parent value, which is either Empty when a list header -- is first created, or the value that has been set by Set_Parent. + -- Parent has the same name as the one in Atree; List_Parent can be used + -- more easily in the debugger. - procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id); + procedure Set_List_Parent (List : List_Id; Node : Node_Or_Entity_Id); + pragma Inline (Set_List_Parent); + procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) + renames Set_List_Parent; pragma Inline (Set_Parent); -- Sets the parent field of the given list to reference the given node diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6082,7 +6082,7 @@ package body Sem_Ch8 is -- If not that special case, then just reset the Etype else - Set_Etype (N, Etype (Entity (N))); + Set_Etype (N, Entyp); end if; end; end if;