From patchwork Fri May 26 07:35:55 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: 70121 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 E212B3888833 for ; Fri, 26 May 2023 07:37:46 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org E212B3888833 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1685086666; bh=HVUMDbpIU8qD/hzqz3gDhKU7NPPtRpt9mmaT99kaE/g=; h=To:Cc:Subject:Date:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:List-Subscribe:From:Reply-To:From; b=btRPLzyxOm+iA/jRelZheur6ur+VyEvOHKAdctF9Mm5Fy4GDGRCS33w0GfRLkytBC vkz2hv3/l4NvfxIPGR73IOIdCtwA/3cVSRpnkc31WcmaW5WPX0pK+N9zpWWAA9F/A4 y+dkI6bU8Hf148kU+tIdGKKDUzIuTxylxr9GijUk= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x430.google.com (mail-wr1-x430.google.com [IPv6:2a00:1450:4864:20::430]) by sourceware.org (Postfix) with ESMTPS id E067A3858C54 for ; Fri, 26 May 2023 07:35:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org E067A3858C54 Received: by mail-wr1-x430.google.com with SMTP id ffacd0b85a97d-30ad8f33f1aso117986f8f.0 for ; Fri, 26 May 2023 00:35:57 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1685086557; x=1687678557; 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=HVUMDbpIU8qD/hzqz3gDhKU7NPPtRpt9mmaT99kaE/g=; b=OUxzjZH0lXgnFJv8wiLEJopqI3bINa360KNlptoEgW9IhkZWZYQSyjU5RAB3qpkXiW zaJ9SyQbsaDfgEgS6Uvy0xVr8dmRqbJXJb5ZoA260e3GFkdBAgWSDFL6iGrZjRqkQ2T8 i+0miSBk10E4krXCe6koZlZAA/RP5csp1C3X8WfKJGM+0ERcLk8M9+8GBjh7Kq6Z02cl jDshyvtKiaxqpyrDhRATgdJrOTtu19KWSKfqG+HSLuU9MuHcF4ZHb4OSPTuIvnJLxrc6 uNjoiI6a2yf9rOwWDPy+CtUruYD3e9xtk1ke6IJarAd27bjdGEMEsr1mMhONrP9tZqMr Hx1A== X-Gm-Message-State: AC+VfDw1cr3i1oIupeBnh+2SdE7JpVidDNJroaffVbiPqyNXtctCe0V+ F/d1plhtaA3yVkFw5681BkL2fvHo0bWKNrMrZReqfw== X-Google-Smtp-Source: ACHHUZ6p4zUiqn9vYlfj2A3wEJOK8vx6TuXXhWSTazqki+OSiS/rD0681aDI2/WdtTRdod4qGAm/cg== X-Received: by 2002:a5d:69cf:0:b0:306:77da:13a with SMTP id s15-20020a5d69cf000000b0030677da013amr612647wrw.25.1685086557195; Fri, 26 May 2023 00:35:57 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:777b:eef4:6f79:f26f]) by smtp.gmail.com with ESMTPSA id 8-20020a05600c024800b003f4e8530696sm4243958wmj.46.2023.05.26.00.35.56 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 26 May 2023 00:35:56 -0700 (PDT) To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Fix missing finalization in library-level instance body Date: Fri, 26 May 2023 09:35:55 +0200 Message-Id: <20230526073555.2068158-1-poulhies@adacore.com> X-Mailer: git-send-email 2.40.0 MIME-Version: 1.0 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 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: =?utf-8?q?Marc_Poulhi=C3=A8s_via_Gcc-patches?= From: =?utf-8?q?Marc_Poulhi=C3=A8s?= Reply-To: =?utf-8?q?Marc_Poulhi=C3=A8s?= Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" From: Eric Botcazou This extends the delaying mechanism present in the cases where the instance is not at library level, so as to wait until after the instantiation of the body is performed, before generating the finalizer of the compilation unit. gcc/ada/ * einfo.ads (Delay_Cleanups): Document new usage. * exp_ch7.ads (Build_Finalizer): New declaration. * exp_ch7.adb (Build_Finalizer.Process_Declarations): Do not treat library-level package instantiations specially. (Build_Finalizer): Return early for package bodies and specs that are not compilation units instead of using a more convoluted test. (Expand_N_Package_Body): Do not build a finalizer if Delay_Cleanups is set on the defining entity. (Expand_N_Package_Declaration): Likewise. * inline.ads (Pending_Body_Info): Reorder and add Fin_Scop. (Add_Pending_Instantiation): Add Fin_Scop parameter. * inline.adb (Add_Pending_Instantiation): Likewise and copy it into the Pending_Body_Info appended to Pending_Instantiations. (Add_Scope_To_Clean): Change parameter name to Scop and remove now irrelevant processing. (Cleanup_Scopes): Deal with scopes that are package specs or bodies. (Instantiate_Body): For package instantiations, deal specially with scopes that are package bodies and with scopes that are dynamic. Pass the resulting scope to Add_Scope_To_Clean directly. * sem_ch12.adb (Analyze_Package_Instantiation): In the case where a body is needed, compute the enclosing finalization scope and pass it in the call to Add_Pending_Instantiation. (Inline_Instance_Body): Adjust aggregate passed in the calls to Instantiate_Package_Body. (Load_Parent_Of_Generic): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/einfo.ads | 12 ++-- gcc/ada/exp_ch7.adb | 133 +++++-------------------------------- gcc/ada/exp_ch7.ads | 23 +++++++ gcc/ada/inline.adb | 154 ++++++++++++++++++++++++++++++------------- gcc/ada/inline.ads | 14 ++-- gcc/ada/sem_ch12.adb | 114 +++++++++++++++++--------------- 6 files changed, 222 insertions(+), 228 deletions(-) diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7dc2bd178cc..ef5201a68ff 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -864,12 +864,12 @@ package Einfo is -- and IN OUT parameters in the absence of errors). -- Delay_Cleanups --- Defined in entities that have finalization lists (subprograms --- blocks, and tasks). Set if there are pending generic body --- instantiations for the corresponding entity. If this flag is --- set, then generation of cleanup actions for the corresponding --- entity must be delayed, since the insertion of the generic body --- may affect cleanup generation (see Inline for further details). +-- Defined in entities that have finalization lists (subprograms, blocks +-- and tasks) or finalizers (package specs and bodies). Set if there are +-- pending package body instantiations for the corresponding entity. If +-- it is set, then generation of cleanup actions for the corresponding +-- entity must be delayed, since the insertion of the package bodies may +-- affect cleanup generation (see Inline for further details). -- Delta_Value -- Defined in fixed and decimal types. Points to a universal real diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 98a62970cd0..1586e8fbfca 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -281,29 +281,6 @@ package body Exp_Ch7 is -- does not contain the above constructs, the routine returns an empty -- list. - procedure Build_Finalizer - (N : Node_Id; - Clean_Stmts : List_Id; - Mark_Id : Entity_Id; - Top_Decls : List_Id; - Defer_Abort : Boolean; - Fin_Id : out Entity_Id); - -- N may denote an accept statement, block, entry body, package body, - -- package spec, protected body, subprogram body, or a task body. Create - -- a procedure which contains finalization calls for all controlled objects - -- declared in the declarative or statement region of N. The calls are - -- built in reverse order relative to the original declarations. In the - -- case of a task body, the routine delays the creation of the finalizer - -- until all statements have been moved to the task body procedure. - -- Clean_Stmts may contain additional context-dependent code used to abort - -- asynchronous calls or complete tasks (see Build_Cleanup_Statements). - -- Mark_Id is the secondary stack used in the current context or Empty if - -- missing. Top_Decls is the list on which the declaration of the finalizer - -- is attached in the non-package case. Defer_Abort indicates that the - -- statements passed in perform actions that require abort to be deferred, - -- such as for task termination. Fin_Id is the finalizer declaration - -- entity. - procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id); -- N is a construct that contains a handled sequence of statements, Fin_Id -- is the entity of a finalizer. Create an At_End handler that covers the @@ -2498,73 +2475,6 @@ package body Exp_Ch7 is end if; end if; - -- Call the xxx__finalize_body procedure of a library level - -- package instantiation if the body contains finalization - -- statements. - - if Present (Generic_Parent (Spec)) - and then Is_Library_Level_Entity (Pack_Id) - and then Present (Body_Entity (Generic_Parent (Spec))) - then - if Preprocess then - declare - P : Node_Id; - begin - P := Parent (Body_Entity (Generic_Parent (Spec))); - while Present (P) - and then Nkind (P) /= N_Package_Body - loop - P := Parent (P); - end loop; - - if Present (P) then - Old_Counter_Val := Counter_Val; - Process_Declarations (Declarations (P), Preprocess); - - -- Note that we are processing the generic body - -- template and not the actually instantiation - -- (which is generated too late for us to process - -- it), so there is no need to update in particular - -- Last_Top_Level_Ctrl_Construct here. - - if Counter_Val > Old_Counter_Val then - Counter_Val := Old_Counter_Val; - Set_Has_Controlled_Component (Pack_Id); - end if; - end if; - end; - - elsif Has_Controlled_Component (Pack_Id) then - - -- We import the xxx__finalize_body routine since the - -- generic body will be instantiated later. - - declare - Id : constant Node_Id := - Make_Defining_Identifier (Loc, - New_Finalizer_Name (Defining_Unit_Name (Spec), - For_Spec => False)); - - begin - Set_Has_Qualified_Name (Id); - Set_Has_Fully_Qualified_Name (Id); - Set_Is_Imported (Id); - Set_Has_Completion (Id); - Set_Interface_Name (Id, - Make_String_Literal (Loc, - Strval => Get_Name_String (Chars (Id)))); - - Append_New_To (Finalizer_Stmts, - Make_Subprogram_Declaration (Loc, - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Id))); - Append_To (Finalizer_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Id, Loc))); - end; - end if; - end if; - -- Nested package bodies, avoid generics elsif Nkind (Decl) = N_Package_Body then @@ -3541,34 +3451,15 @@ package body Exp_Ch7 is end if; end if; - -- Do not process nested packages since those are handled by the - -- enclosing scope's finalizer. Do not process non-expanded package - -- instantiations since those will be re-analyzed and re-expanded. + -- We do not need to process nested packages since they are handled by + -- the finalizer of the enclosing scope, including at library level. + -- And we do not build two finalizers for an instance without body that + -- is a library unit (see Analyze_Package_Instantiation). if For_Package - and then - (not Is_Library_Level_Entity (Spec_Id) - - -- Nested packages are library-level entities, but do not need to - -- be processed separately. - - or else Scope_Depth (Spec_Id) /= Uint_1 - - -- Do not build two finalizers for an instance without body that - -- is a library unit (see Analyze_Package_Instantiation). - - or else (Is_Generic_Instance (Spec_Id) - and then Package_Instantiation (Spec_Id) = N)) - - -- Still need to process library-level package body instances, whose - -- instantiation was deferred and thus could not be seen during the - -- processing of the enclosing scope, and which may contain objects - -- requiring finalization. - - and then not - (For_Package_Body - and then Is_Library_Level_Entity (Spec_Id) - and then Is_Generic_Instance (Spec_Id)) + and then (not Is_Compilation_Unit (Spec_Id) + or else (Is_Generic_Instance (Spec_Id) + and then Package_Instantiation (Spec_Id) = N)) then return; end if; @@ -5188,7 +5079,9 @@ package body Exp_Ch7 is -- Encode entity names in package body procedure Expand_N_Package_Body (N : Node_Id) is + Id : constant Entity_Id := Defining_Entity (N); Spec_Id : constant Entity_Id := Corresponding_Spec (N); + Fin_Id : Entity_Id; begin @@ -5242,7 +5135,9 @@ package body Exp_Ch7 is Qualify_Entity_Names (N); - if Ekind (Spec_Id) /= E_Generic_Package then + if Ekind (Spec_Id) /= E_Generic_Package + and then not Delay_Cleanups (Id) + then Build_Finalizer (N => N, Clean_Stmts => No_List, @@ -5369,7 +5264,9 @@ package body Exp_Ch7 is Qualify_Entity_Names (N); - if Ekind (Id) /= E_Generic_Package then + if Ekind (Id) /= E_Generic_Package + and then not Delay_Cleanups (Id) + then Build_Finalizer (N => N, Clean_Stmts => No_List, diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 37754dbd3f9..a131e55f5c3 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -118,6 +118,29 @@ package Exp_Ch7 is -- finalization master must be analyzed. Insertion_Node is the insertion -- point before which the master is to be inserted. + procedure Build_Finalizer + (N : Node_Id; + Clean_Stmts : List_Id; + Mark_Id : Entity_Id; + Top_Decls : List_Id; + Defer_Abort : Boolean; + Fin_Id : out Entity_Id); + -- N may denote an accept statement, block, entry body, package body, + -- package spec, protected body, subprogram body, or a task body. Create + -- a procedure which contains finalization calls for all controlled objects + -- declared in the declarative or statement region of N. The calls are + -- built in reverse order relative to the original declarations. In the + -- case of a task body, the routine delays the creation of the finalizer + -- until all statements have been moved to the task body procedure. + -- Clean_Stmts may contain additional context-dependent code used to abort + -- asynchronous calls or complete tasks (see Build_Cleanup_Statements). + -- Mark_Id is the secondary stack used in the current context or Empty if + -- missing. Top_Decls is the list on which the declaration of the finalizer + -- is attached in the non-package case. Defer_Abort indicates that the + -- statements passed in perform actions that require abort to be deferred, + -- such as for task termination. Fin_Id is the finalizer declaration + -- entity. + procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); -- Build one controlling procedure when a late body overrides one of the -- controlling operations. diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index b7dafde9cf9..a4c32e984da 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -334,17 +334,17 @@ package body Inline is -- Deferred Cleanup Actions -- ------------------------------ - -- The cleanup actions for scopes that contain instantiations is delayed - -- until after expansion of those instantiations, because they may contain - -- finalizable objects or tasks that affect the cleanup code. A scope - -- that contains instantiations only needs to be finalized once, even - -- if it contains more than one instance. We keep a list of scopes - -- that must still be finalized, and call cleanup_actions after all - -- the instantiations have been completed. + -- The cleanup actions for scopes that contain package instantiations with + -- a body are delayed until after the package body is instantiated. because + -- the body may contain finalizable objects or other constructs that affect + -- the cleanup code. A scope that contains such instantiations only needs + -- to be finalized once, even though it may contain more than one instance. + -- We keep a list of scopes that must still be finalized and Cleanup_Scopes + -- will be invoked after all the body instantiations have been completed. To_Clean : Elist_Id; - procedure Add_Scope_To_Clean (Inst : Entity_Id); + procedure Add_Scope_To_Clean (Scop : Entity_Id); -- Build set of scopes on which cleanup actions must be performed procedure Cleanup_Scopes; @@ -783,7 +783,11 @@ package body Inline is -- Add_Pending_Instantiation -- -------------------------------- - procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is + procedure Add_Pending_Instantiation + (Inst : Node_Id; + Act_Decl : Node_Id; + Fin_Scop : Node_Id := Empty) + is Act_Decl_Id : Entity_Id; Index : Int; @@ -802,11 +806,12 @@ package body Inline is -- for later processing by Instantiate_Bodies. Pending_Instantiations.Append - ((Act_Decl => Act_Decl, + ((Inst_Node => Inst, + Act_Decl => Act_Decl, + Fin_Scop => Fin_Scop, Config_Switches => Save_Config_Switches, Current_Sem_Unit => Current_Sem_Unit, Expander_Status => Expander_Active, - Inst_Node => Inst, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, Scope_Suppress => Scope_Suppress, Warnings => Save_Warnings)); @@ -838,37 +843,10 @@ package body Inline is -- Add_Scope_To_Clean -- ------------------------ - procedure Add_Scope_To_Clean (Inst : Entity_Id) is - Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst); + procedure Add_Scope_To_Clean (Scop : Entity_Id) is Elmt : Elmt_Id; begin - -- If the instance appears in a library-level package declaration, - -- all finalization is global, and nothing needs doing here. - - if Scop = Standard_Standard then - return; - end if; - - -- If the instance is within a generic unit, no finalization code - -- can be generated. Note that at this point all bodies have been - -- analyzed, and the scope stack itself is not present, and the flag - -- Inside_A_Generic is not set. - - declare - S : Entity_Id; - - begin - S := Scope (Inst); - while Present (S) and then S /= Standard_Standard loop - if Is_Generic_Unit (S) then - return; - end if; - - S := Scope (S); - end loop; - end; - Elmt := First_Elmt (To_Clean); while Present (Elmt) loop if Node (Elmt) = Scop then @@ -2816,16 +2794,19 @@ package body Inline is -------------------- procedure Cleanup_Scopes is - Elmt : Elmt_Id; Decl : Node_Id; + Elmt : Elmt_Id; + Fin : Entity_Id; + Kind : Entity_Kind; Scop : Entity_Id; begin Elmt := First_Elmt (To_Clean); while Present (Elmt) loop Scop := Node (Elmt); + Kind := Ekind (Scop); - if Ekind (Scop) = E_Block then + if Kind = E_Block then Decl := Parent (Block_Node (Scop)); else @@ -2839,14 +2820,55 @@ package body Inline is end if; end if; - Push_Scope (Scop); - Expand_Cleanup_Actions (Decl); - End_Scope; + -- Finalizers are built only for package specs and bodies that are + -- compilation units, so check that we do not have anything else. + -- Moreover, they must be built at most once for each entity during + -- the compilation of the main unit. However, if other units are + -- later compiled for inlining purposes, they may also contain body + -- instances and, therefore, appear again here, so we need to make + -- sure that we do not build two finalizers for them (note that the + -- contents of the finalizer for these units is irrelevant since it + -- is not output in the generated code). + + if Kind in E_Package | E_Package_Body then + declare + Unit_Entity : constant Entity_Id := + (if Kind = E_Package then Scop else Spec_Entity (Scop)); + + begin + pragma Assert (Is_Compilation_Unit (Unit_Entity) + and then (No (Finalizer (Scop)) + or else Unit_Entity /= Main_Unit_Entity)); + + if No (Finalizer (Scop)) then + Build_Finalizer + (N => Decl, + Clean_Stmts => No_List, + Mark_Id => Empty, + Top_Decls => No_List, + Defer_Abort => False, + Fin_Id => Fin); + + if Present (Fin) then + Set_Finalizer (Scop, Fin); + end if; + end if; + end; + + else + Push_Scope (Scop); + Expand_Cleanup_Actions (Decl); + End_Scope; + end if; Next_Elmt (Elmt); end loop; end Cleanup_Scopes; + ----------------------------------------------- + -- Establish_Actual_Mapping_For_Inlined_Call -- + ----------------------------------------------- + procedure Establish_Actual_Mapping_For_Inlined_Call (N : Node_Id; Subp : Entity_Id; @@ -4831,6 +4853,8 @@ package body Inline is ------------------------ procedure Instantiate_Body (Info : Pending_Body_Info) is + Scop : Entity_Id; + begin -- If the instantiation node is absent, it has been removed as part -- of unreachable code. @@ -4845,9 +4869,47 @@ package body Inline is elsif Nkind (Info.Inst_Node) = N_Package_Body then null; - elsif Nkind (Info.Act_Decl) = N_Package_Declaration then + -- For other package instances, instantiate the body and register the + -- finalization scope, if any, for subsequent generation of cleanups. + + elsif Nkind (Info.Inst_Node) = N_Package_Instantiation then + + -- If the enclosing finalization scope is a package body, set the + -- In_Package_Body flag on its spec. This is required, in the case + -- where the body contains other package instantiations that have + -- a body, for Analyze_Package_Instantiation to compute a correct + -- finalization scope. + + if Present (Info.Fin_Scop) + and then Ekind (Info.Fin_Scop) = E_Package_Body + then + Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), True); + end if; + Instantiate_Package_Body (Info); - Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl)); + + if Present (Info.Fin_Scop) then + Scop := Info.Fin_Scop; + + -- If the enclosing finalization scope is dynamic, the instance + -- may have been relocated, for example if it was declared in a + -- protected entry, protected subprogram, or task body. + + if Is_Dynamic_Scope (Scop) then + Scop := + Enclosing_Dynamic_Scope (Defining_Entity (Info.Act_Decl)); + end if; + + Add_Scope_To_Clean (Scop); + + -- Reset the In_Package_Body flag if it was set above + + if Ekind (Info.Fin_Scop) = E_Package_Body then + Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), False); + end if; + end if; + + -- For subprogram instances, always instantiate the body else Instantiate_Subprogram_Body (Info); diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index 9d836173320..65c0968c1e4 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -61,9 +61,15 @@ package Inline is -- See full description in body of Sem_Ch12 for more details type Pending_Body_Info is record + Inst_Node : Node_Id; + -- Node for instantiation that requires the body + Act_Decl : Node_Id; -- Declaration for package or subprogram spec for instantiation + Fin_Scop : Node_Id; + -- Enclosing finalization scope for package instantiation + Config_Switches : Config_Switches_Type; -- Capture the values of configuration switches @@ -76,9 +82,6 @@ package Inline is -- If the body is instantiated only for semantic checking, expansion -- must be inhibited. - Inst_Node : Node_Id; - -- Node for instantiation that requires the body - Scope_Suppress : Suppress_Record; Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; -- Save suppress information at the point of instantiation. Used to @@ -119,7 +122,10 @@ package Inline is -- Add E's enclosing unit to Inlined_Bodies so that E can be subsequently -- retrieved and analyzed. N is the node giving rise to the call to E. - procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id); + procedure Add_Pending_Instantiation + (Inst : Node_Id; + Act_Decl : Node_Id; + Fin_Scop : Node_Id := Empty); -- Add an entry in the table of generic bodies to be instantiated. procedure Analyze_Inlined_Bodies; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index b8cd16080fe..4fefcc8fb46 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -4794,66 +4794,68 @@ package body Sem_Ch12 is Needs_Body := False; end if; + -- If the context requires a full instantiation, set things up for + -- subsequent construction of the body. + if Needs_Body then - -- Indicate that the enclosing scopes contain an instantiation, - -- and that cleanup actions should be delayed until after the - -- instance body is expanded. + declare + Fin_Scop, S : Entity_Id; - Check_Forward_Instantiation (Gen_Decl); - if Nkind (N) = N_Package_Instantiation then - declare - Enclosing_Master : Entity_Id; + begin + Check_Forward_Instantiation (Gen_Decl); - begin - -- Loop to search enclosing masters + Fin_Scop := Empty; - Enclosing_Master := Current_Scope; - Scope_Loop : while Enclosing_Master /= Standard_Standard loop - if Ekind (Enclosing_Master) = E_Package then - if Is_Compilation_Unit (Enclosing_Master) then - exit Scope_Loop; - else - Enclosing_Master := Scope (Enclosing_Master); - end if; + -- For a package instantiation that is not a compilation unit, + -- indicate that cleanup actions of the innermost enclosing + -- scope for which they are generated should be delayed until + -- after the package body is instantiated. + + if Nkind (N) = N_Package_Instantiation + and then not Is_Compilation_Unit (Act_Decl_Id) + then + S := Current_Scope; + + while S /= Standard_Standard loop + -- Cleanup actions are not generated within generic units + -- or in the formal part of generic units. - elsif Is_Generic_Unit (Enclosing_Master) - or else Ekind (Enclosing_Master) = E_Void + if Inside_A_Generic + or else Is_Generic_Unit (S) + or else Ekind (S) = E_Void then - -- Cleanup actions will eventually be performed on the - -- enclosing subprogram or package instance, if any. - -- Enclosing scope is void in the formal part of a - -- generic subprogram. + exit; - exit Scope_Loop; + -- For package scopes, cleanup actions are generated only + -- for compilation units, for spec and body separately. - else - Set_Delay_Cleanups (Enclosing_Master); + elsif Ekind (S) = E_Package then + if Is_Compilation_Unit (S) then + if In_Package_Body (S) then + Fin_Scop := Body_Entity (S); + else + Fin_Scop := S; + end if; - while Ekind (Enclosing_Master) = E_Block loop - Enclosing_Master := Scope (Enclosing_Master); - end loop; + Set_Delay_Cleanups (Fin_Scop); + exit; - if Is_Task_Type (Enclosing_Master) then - declare - TBP : constant Node_Id := - Get_Task_Body_Procedure - (Enclosing_Master); - begin - if Present (TBP) then - Set_Delay_Cleanups (TBP); - end if; - end; + else + S := Scope (S); end if; - exit Scope_Loop; - end if; - end loop Scope_Loop; - end; + -- Cleanup actions are generated for all dynamic scopes - -- Make entry in table + else + Fin_Scop := S; + Set_Delay_Cleanups (Fin_Scop); + exit; + end if; + end loop; + end if; - Add_Pending_Instantiation (N, Act_Decl); - end if; + Add_Pending_Instantiation (N, Act_Decl, Fin_Scop); + end; end if; Set_Categorization_From_Pragmas (Act_Decl); @@ -5252,11 +5254,12 @@ package body Sem_Ch12 is Instantiate_Package_Body (Body_Info => - ((Act_Decl => Act_Decl, + ((Inst_Node => N, + Act_Decl => Act_Decl, + Fin_Scop => Empty, Config_Switches => Config_Attrs, Current_Sem_Unit => Current_Sem_Unit, Expander_Status => Expander_Active, - Inst_Node => N, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, Scope_Suppress => Scope_Suppress, Warnings => Save_Warnings)), @@ -5366,11 +5369,12 @@ package body Sem_Ch12 is else Instantiate_Package_Body (Body_Info => - ((Act_Decl => Act_Decl, + ((Inst_Node => N, + Act_Decl => Act_Decl, + Fin_Scop => Empty, Config_Switches => Save_Config_Switches, Current_Sem_Unit => Current_Sem_Unit, Expander_Status => Expander_Active, - Inst_Node => N, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, Scope_Suppress => Scope_Suppress, Warnings => Save_Warnings)), @@ -14694,13 +14698,14 @@ package body Sem_Ch12 is Decl := First_Elmt (Previous_Instances); while Present (Decl) loop Info := - (Act_Decl => + (Inst_Node => Node (Decl), + Act_Decl => Instance_Spec (Node (Decl)), + Fin_Scop => Empty, Config_Switches => Save_Config_Switches, Current_Sem_Unit => Get_Code_Unit (Sloc (Node (Decl))), Expander_Status => Exp_Status, - Inst_Node => Node (Decl), Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, Scope_Suppress => Scope_Suppress, @@ -14754,12 +14759,13 @@ package body Sem_Ch12 is Instantiate_Package_Body (Body_Info => - ((Act_Decl => True_Parent, + ((Inst_Node => Inst_Node, + Act_Decl => True_Parent, + Fin_Scop => Empty, Config_Switches => Save_Config_Switches, Current_Sem_Unit => Get_Code_Unit (Sloc (Inst_Node)), Expander_Status => Exp_Status, - Inst_Node => Inst_Node, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, Scope_Suppress => Scope_Suppress, Warnings => Save_Warnings)),