From patchwork Mon May 2 10:05:12 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 617450 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3qz0L80rs2z9sRZ for ; Mon, 2 May 2016 20:05:35 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=P8L5tNgL; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=Te3Cfni0mbSf+Mpj3Ke/WiJqUC1PJvfxRKvp+jKxbAD3l/Oabs OreQ/tIgelBSQG0xD25NdNrhGUbZ1wZr0n2/HGbBDOo50yJE7tbbJIe9mX1btSjK SUVeJSHZHj3KGaT4zIc2KxAYmclAEMmfbkK/9mEbqXWTeEC79TAh1NY2k= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=m0p185RPeCmVLcez1wIGBPLpqO4=; b=P8L5tNgL4pVCSS8bZ0oQ sUSTdd6LPyrkDgMGSjgDBIol23hz288JMXx96RHyVGzdd5d/Mu7awt2Y5mQWvO0I t/Cz8JSRoSy6OeaEO2pXNBt+fFB1GEGWzPZYce+KbiJ9UPSs1LAHHUTOmtk3fHwY EBnXy7KZWK3J/v2kJW+aFaU= Received: (qmail 119961 invoked by alias); 2 May 2016 10:05:25 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 119939 invoked by uid 89); 2 May 2016 10:05:24 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=2.2 required=5.0 tests=AWL, BAYES_50, KAM_ASCII_DIVIDERS, KAM_LAZY_DOMAIN_SECURITY, RCVD_IN_DNSWL_NONE autolearn=no version=3.3.2 spammy=nam, Natural, sk:number_, rooted X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Mon, 02 May 2016 10:05:14 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 370AA116752; Mon, 2 May 2016 06:05:12 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id tRbH5z6wOotu; Mon, 2 May 2016 06:05:12 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 1614611674F; Mon, 2 May 2016 06:05:12 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 12A1B41B; Mon, 2 May 2016 06:05:12 -0400 (EDT) Date: Mon, 2 May 2016 06:05:12 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Optimization of anonymous access-to-controlled types Message-ID: <20160502100512.GA1379@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch modifies the creation of finalization masters for anonymous access- to-controlled types. Prior to this change, each compilation unit utilized a single heterogeneous finalization master to service all allocations where the associated type is anonymous access-to-controlled. This patch removes the use of the single heterogeneous finalization master and instead introduces multiple homogenous finalization masters. This leads to increase in performance because allocation no longer needs to maintain a mapping between allocated object and corresponding Finalize_Address primitive in a runtime hash data structure. As a result, anonymous access-to-controlled types are on par with named access-to- controlled types. ------------ -- Source -- ------------ -- types.ads with Ada.Finalization; use Ada.Finalization; package Types is type Ctrl is new Controlled with record Id : Natural; end record; -- Anonymous types type Anon_Discr (Discr : access Ctrl) is null record; type Anon_Comps is record Comp_1 : access Ctrl; Comp_2 : access Ctrl; end record; type Anon_Array is array (1 .. 5) of access Ctrl; -- Named types type Ctrl_Ptr is access all Ctrl; type Named_Discr (Discr : Ctrl_Ptr) is null record; type Named_Discr_Ptr is access all Named_Discr; type Named_Comps is record Comp_1 : Ctrl_Ptr; Comp_2 : Ctrl_Ptr; end record; end Types; -- performance.adb with Ada.Calendar; use Ada.Calendar; with Ada.Finalization; use Ada.Finalization; with Ada.Text_IO; use Ada.Text_IO; with Types; use Types; procedure Performance is Percentage : constant := 0.3; -- 30% Max_Iterations : constant := 50_000; Diff_A : Duration; Diff_N : Duration; Factor : Duration; Start_A : Time; Start_N : Time; begin Start_A := Clock; for Iteration in 1 .. Max_Iterations loop declare Anon_Discr_Obj : access Anon_Discr := new Anon_Discr'(Discr => new Ctrl'(Controlled with Id => 1)); Anon_Comps_Obj : constant Anon_Comps := (Comp_1 => new Ctrl'(Controlled with Id => 2), Comp_2 => new Ctrl'(Controlled with Id => 3)); begin null; end; end loop; Diff_A := Clock - Start_A; Start_N := Clock; for Iteration in 1 .. Max_Iterations loop declare Named_Discr_Obj : Named_Discr_Ptr := new Named_Discr'(Discr => new Ctrl'(Controlled with Id => 4)); Named_Comps_Obj : constant Named_Comps := (Comp_1 => new Ctrl'(Controlled with Id => 5), Comp_2 => new Ctrl'(Controlled with Id => 6)); begin null; end; end loop; Diff_N := Clock - Start_N; Factor := Diff_N * Percentage; if Diff_N - Factor < Diff_A and then Diff_A < Diff_N + Factor then Put_Line ("Anonymous vs Named within expected percentage"); else Put_Line ("ERROR"); end if; end Performance; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q performance.adb $ ./performance Anonymous vs Named within expected percentage Tested on x86_64-pc-linux-gnu, committed on trunk 2016-05-02 Hristian Kirtchev * einfo.adb Anonymous_Master now uses Node35. (Anonymous_Master): Update the assertion and node reference. (Set_Anonymous_Master): Update the assertion and node reference. (Write_Field35_Name): Add output for Anonymous_Master. (Write_Field36_Name): The output is now undefined. * einfo.ads Update the node and description of attribute Anonymous_Master. Remove prior occurrences in entities as this is now a type attribute. * exp_ch3.adb (Expand_Freeze_Array_Type): Remove local variable Ins_Node. Anonymous access- to-controlled component types no longer need finalization masters. The master is now built when a related allocator is expanded. (Expand_Freeze_Record_Type): Remove local variable Has_AACC. Do not detect whether the record type has at least one component of anonymous access-to- controlled type. These types no longer need finalization masters. The master is now built when a related allocator is expanded. * exp_ch4.adb Remove with and use clauses for Lib and Sem_Ch8. (Current_Anonymous_Master): Removed. (Expand_N_Allocator): Call Build_Anonymous_Master to create a finalization master for an anonymous access-to-controlled type. * exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call): Call routine Build_Anonymous_Master to create a finalization master for an anonymous access-to-controlled type. * exp_ch7.adb (Allows_Finalization_Master): New routine. (Build_Anonymous_Master): New routine. (Build_Finalization_Master): Remove formal parameter For_Anonymous. Use Allows_Finalization_Master to determine whether circumstances warrant a finalization master. This routine no longer creates masters for anonymous access-to-controlled types. (In_Deallocation_Instance): Removed. * exp_ch7.ads (Build_Anonymous_Master): New routine. (Build_Finalization_Master): Remove formal parameter For_Anonymous and update the comment on usage. * sem_util.adb (Get_Qualified_Name): New routines. (Output_Name): Reimplemented. (Output_Scope): Removed. * sem_util.ads (Get_Qualified_Name): New routines. Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 235706) +++ exp_ch7.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -301,6 +301,9 @@ Finalize_Case => TSS_Deep_Finalize, Address_Case => TSS_Finalize_Address); + function Allows_Finalization_Master (Typ : Entity_Id) return Boolean; + -- Determine whether access type Typ may have a finalization master + procedure Build_Array_Deep_Procs (Typ : Entity_Id); -- Build the deep Initialize/Adjust/Finalize for a record Typ with -- Has_Controlled_Component set and store them using the TSS mechanism. @@ -427,7 +430,333 @@ -- [Deep_]Finalize (Acc_Typ (V).all); -- end; + -------------------------------- + -- Allows_Finalization_Master -- + -------------------------------- + + function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is + function In_Deallocation_Instance (E : Entity_Id) return Boolean; + -- Determine whether entity E is inside a wrapper package created for + -- an instance of Ada.Unchecked_Deallocation. + + ------------------------------ + -- In_Deallocation_Instance -- + ------------------------------ + + function In_Deallocation_Instance (E : Entity_Id) return Boolean is + Pkg : constant Entity_Id := Scope (E); + Par : Node_Id := Empty; + + begin + if Ekind (Pkg) = E_Package + and then Present (Related_Instance (Pkg)) + and then Ekind (Related_Instance (Pkg)) = E_Procedure + then + Par := Generic_Parent (Parent (Related_Instance (Pkg))); + + return + Present (Par) + and then Chars (Par) = Name_Unchecked_Deallocation + and then Chars (Scope (Par)) = Name_Ada + and then Scope (Scope (Par)) = Standard_Standard; + end if; + + return False; + end In_Deallocation_Instance; + + -- Local variables + + Desig_Typ : constant Entity_Id := Designated_Type (Typ); + Ptr_Typ : constant Entity_Id := + Root_Type_Of_Full_View (Base_Type (Typ)); + + -- Start of processing for Allows_Finalization_Master + + begin + -- Certain run-time configurations and targets do not provide support + -- for controlled types and therefore do not need masters. + + if Restriction_Active (No_Finalization) then + return False; + + -- Do not consider C and C++ types since it is assumed that the non-Ada + -- side will handle their clean up. + + elsif Convention (Desig_Typ) = Convention_C + or else Convention (Desig_Typ) = Convention_CPP + then + return False; + + -- Do not consider types that return on the secondary stack + + elsif Present (Associated_Storage_Pool (Ptr_Typ)) + and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool) + then + return False; + + -- Do not consider types which may never allocate an object + + elsif No_Pool_Assigned (Ptr_Typ) then + return False; + + -- Do not consider access types coming from Ada.Unchecked_Deallocation + -- instances. Even though the designated type may be controlled, the + -- access type will never participate in allocation. + + elsif In_Deallocation_Instance (Ptr_Typ) then + return False; + + -- Do not consider non-library access types when restriction + -- No_Nested_Finalization is in effect since masters are controlled + -- objects. + + elsif Restriction_Active (No_Nested_Finalization) + and then not Is_Library_Level_Entity (Ptr_Typ) + then + return False; + + -- Do not create finalization masters in GNATprove mode because this + -- causes unwanted extra expansion. A compilation in this mode must + -- keep the tree as close as possible to the original sources. + + elsif GNATprove_Mode then + return False; + + -- Otherwise the access type may use a finalization master + + else + return True; + end if; + end Allows_Finalization_Master; + ---------------------------- + -- Build_Anonymous_Master -- + ---------------------------- + + procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is + function Create_Anonymous_Master + (Desig_Typ : Entity_Id; + Unit_Id : Entity_Id; + Unit_Decl : Node_Id) return Entity_Id; + -- Create a new anonymous finalization master for access type Ptr_Typ + -- with designated type Desig_Typ. The declaration of the master along + -- with its specialized initialization is inserted in the declarative + -- part of unit Unit_Decl. Unit_Id denotes the entity of Unit_Decl. + + function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean; + -- Determine whether arbitrary node N appears within the subtree rooted + -- at node Root. + + ----------------------------- + -- Create_Anonymous_Master -- + ----------------------------- + + function Create_Anonymous_Master + (Desig_Typ : Entity_Id; + Unit_Id : Entity_Id; + Unit_Decl : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (Unit_Id); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl); + Decls : List_Id; + FM_Decl : Node_Id; + FM_Id : Entity_Id; + FM_Init : Node_Id; + Pref : Character; + Unit_Spec : Node_Id; + + begin + -- Find the declarative list of the unit + + if Nkind (Unit_Decl) = N_Package_Declaration then + Unit_Spec := Specification (Unit_Decl); + Decls := Visible_Declarations (Unit_Spec); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (Unit_Spec, Decls); + end if; + + -- Package body or subprogram case + + -- ??? A subprogram spec or body that acts as a compilation unit may + -- contain a formal parameter of an anonymous access-to-controlled + -- type initialized by an allocator. + + -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl); + + -- There is no suitable place to create the anonymous master as the + -- subprogram is not in a declarative list. + + else + Decls := Declarations (Unit_Decl); + + if No (Decls) then + Decls := New_List; + Set_Declarations (Unit_Decl, Decls); + end if; + end if; + + -- Step 1: Anonymous master creation + + -- Use a unique prefix in case the same unit requires two anonymous + -- masters, one for the spec (S) and one for the body (B). + + if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then + Pref := 'S'; + else + Pref := 'B'; + end if; + + -- The name of the anonymous master has the following format: + + -- [BS]scopN__scop1__chars_of_desig_typAM + + -- The name utilizes the fully qualified name of the designated type + -- in case two controlled types with the same name are declared in + -- different scopes and both have anonymous access types. + + FM_Id := + Make_Defining_Identifier (Loc, + New_External_Name + (Related_Id => Get_Qualified_Name (Desig_Typ), + Suffix => "AM", + Prefix => Pref)); + + -- Associate the anonymous master with the designated type. This + -- ensures that any additional anonymous access types with the same + -- designated type will share the same anonymous paster within the + -- same unit. + + Set_Anonymous_Master (Desig_Typ, FM_Id); + + -- Generate: + -- : Finalization_Master; + + FM_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => FM_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)); + + -- Step 2: Initialization actions + + -- Generate: + -- Set_Base_Pool + -- (, Global_Pool_Object'Unrestricted_Access); + + FM_Init := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (FM_Id, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc), + Attribute_Name => Name_Unrestricted_Access))); + + Prepend_To (Decls, FM_Init); + Prepend_To (Decls, FM_Decl); + + -- Since the anonymous master and all its initialization actions are + -- inserted at top level, use the scope of the unit when analyzing. + + Push_Scope (Spec_Id); + Analyze (FM_Decl); + Analyze (FM_Init); + Pop_Scope; + + return FM_Id; + end Create_Anonymous_Master; + + ---------------- + -- In_Subtree -- + ---------------- + + function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is + Par : Node_Id; + + begin + -- Traverse the parent chain until reaching the same root + + Par := N; + while Present (Par) loop + if Par = Root then + return True; + end if; + + Par := Parent (Par); + end loop; + + return False; + end In_Subtree; + + -- Local variables + + Desig_Typ : Entity_Id; + FM_Id : Entity_Id; + Priv_View : Entity_Id; + Unit_Decl : Node_Id; + Unit_Id : Entity_Id; + + -- Start of processing for Build_Anonymous_Master + + begin + -- Nothing to do if the circumstances do not allow for a finalization + -- master. + + if not Allows_Finalization_Master (Ptr_Typ) then + return; + end if; + + Unit_Decl := Unit (Cunit (Current_Sem_Unit)); + Unit_Id := Defining_Entity (Unit_Decl); + + -- The compilation unit is a package instantiation. In this case the + -- anonymous master is associated with the package spec as both the + -- spec and body appear at the same level. + + if Nkind (Unit_Decl) = N_Package_Body + and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation + then + Unit_Id := Corresponding_Spec (Unit_Decl); + Unit_Decl := Unit_Declaration_Node (Unit_Id); + end if; + + -- Use the initial declaration of the designated type when it denotes + -- the full view of an incomplete or private type. This ensures that + -- types with one and two views are treated the same. + + Desig_Typ := Directly_Designated_Type (Ptr_Typ); + Priv_View := Incomplete_Or_Partial_View (Desig_Typ); + + if Present (Priv_View) then + Desig_Typ := Priv_View; + end if; + + FM_Id := Anonymous_Master (Desig_Typ); + + -- The designated type already has at least one anonymous access type + -- pointing to it within the current unit. Reuse the anonymous master + -- because the designated type is the same. + + if Present (FM_Id) + and then In_Subtree (Declaration_Node (FM_Id), Root => Unit_Decl) + then + null; + + -- Otherwise the designated type lacks an anonymous master or it is + -- declared in a different unit. Create a brand new master. + + else + FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl); + end if; + + Set_Finalization_Master (Ptr_Typ, FM_Id); + end Build_Anonymous_Master; + + ---------------------------- -- Build_Array_Deep_Procs -- ---------------------------- @@ -762,7 +1091,6 @@ procedure Build_Finalization_Master (Typ : Entity_Id; - For_Anonymous : Boolean := False; For_Lib_Level : Boolean := False; For_Private : Boolean := False; Context_Scope : Entity_Id := Empty; @@ -773,10 +1101,6 @@ Ptr_Typ : Entity_Id); -- Add access type Ptr_Typ to the pending access type list for type Typ - function In_Deallocation_Instance (E : Entity_Id) return Boolean; - -- Determine whether entity E is inside a wrapper package created for - -- an instance of Ada.Unchecked_Deallocation. - ----------------------------- -- Add_Pending_Access_Type -- ----------------------------- @@ -798,31 +1122,6 @@ Prepend_Elmt (Ptr_Typ, List); end Add_Pending_Access_Type; - ------------------------------ - -- In_Deallocation_Instance -- - ------------------------------ - - function In_Deallocation_Instance (E : Entity_Id) return Boolean is - Pkg : constant Entity_Id := Scope (E); - Par : Node_Id := Empty; - - begin - if Ekind (Pkg) = E_Package - and then Present (Related_Instance (Pkg)) - and then Ekind (Related_Instance (Pkg)) = E_Procedure - then - Par := Generic_Parent (Parent (Related_Instance (Pkg))); - - return - Present (Par) - and then Chars (Par) = Name_Unchecked_Deallocation - and then Chars (Scope (Par)) = Name_Ada - and then Scope (Scope (Par)) = Standard_Standard; - end if; - - return False; - end In_Deallocation_Instance; - -- Local variables Desig_Typ : constant Entity_Id := Designated_Type (Typ); @@ -836,67 +1135,17 @@ -- Start of processing for Build_Finalization_Master begin - -- Certain run-time configurations and targets do not provide support - -- for controlled types. + -- Nothing to do if the circumstances do not allow for a finalization + -- master. - if Restriction_Active (No_Finalization) then + if not Allows_Finalization_Master (Typ) then return; - -- Do not process C, C++ types since it is assumed that the non-Ada side - -- will handle their clean up. - - elsif Convention (Desig_Typ) = Convention_C - or else Convention (Desig_Typ) = Convention_CPP - then - return; - -- Various machinery such as freezing may have already created a -- finalization master. elsif Present (Finalization_Master (Ptr_Typ)) then return; - - -- Do not process types that return on the secondary stack - - elsif Present (Associated_Storage_Pool (Ptr_Typ)) - and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool) - then - return; - - -- Do not process types which may never allocate an object - - elsif No_Pool_Assigned (Ptr_Typ) then - return; - - -- Do not process access types coming from Ada.Unchecked_Deallocation - -- instances. Even though the designated type may be controlled, the - -- access type will never participate in allocation. - - elsif In_Deallocation_Instance (Ptr_Typ) then - return; - - -- Ignore the general use of anonymous access types unless the context - -- requires a finalization master. - - elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type - and then not For_Anonymous - then - return; - - -- Do not process non-library access types when restriction No_Nested_ - -- Finalization is in effect since masters are controlled objects. - - elsif Restriction_Active (No_Nested_Finalization) - and then not Is_Library_Level_Entity (Ptr_Typ) - then - return; - - -- Do not create finalization masters in GNATprove mode because this - -- unwanted extra expansion. A compilation in this mode keeps the tree - -- as close as possible to the original sources. - - elsif GNATprove_Mode then - return; end if; declare @@ -1013,11 +1262,11 @@ Add_Pending_Access_Type (Desig_Typ, Ptr_Typ); end if; - -- A finalization master created for an anonymous access type or an - -- access designating a type with private components must be inserted - -- before a context-dependent node. + -- A finalization master created for an access designating a type + -- with private components is inserted before a context-dependent + -- node. - if For_Anonymous or For_Private then + if For_Private then -- At this point both the scope of the context and the insertion -- mode must be known. @@ -3693,15 +3942,6 @@ end if; end Check_Visibly_Controlled; - ------------------------------- - -- CW_Or_Has_Controlled_Part -- - ------------------------------- - - function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is - begin - return Is_Class_Wide_Type (T) or else Needs_Finalization (T); - end CW_Or_Has_Controlled_Part; - ------------------ -- Convert_View -- ------------------ @@ -3764,6 +4004,15 @@ end if; end Convert_View; + ------------------------------- + -- CW_Or_Has_Controlled_Part -- + ------------------------------- + + function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is + begin + return Is_Class_Wide_Type (T) or else Needs_Finalization (T); + end CW_Or_Has_Controlled_Part; + ------------------------ -- Enclosing_Function -- ------------------------ Index: exp_ch7.ads =================================================================== --- exp_ch7.ads (revision 235706) +++ exp_ch7.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,6 +35,11 @@ -- Finalization Management -- ----------------------------- + procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id); + -- Build a finalization master for an anonymous access-to-controlled type + -- denoted by Ptr_Typ. The master is inserted in the declarations of the + -- current unit. + procedure Build_Controlling_Procs (Typ : Entity_Id); -- Typ is a record, and array type having controlled components. -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize @@ -99,22 +104,19 @@ procedure Build_Finalization_Master (Typ : Entity_Id; - For_Anonymous : Boolean := False; For_Lib_Level : Boolean := False; For_Private : Boolean := False; Context_Scope : Entity_Id := Empty; Insertion_Node : Node_Id := Empty); -- Build a finalization master for an access type. The designated type may -- not necessarely be controlled or need finalization actions depending on - -- the context. Flag For_Anonymous must be set when creating a master for - -- an anonymous access type. Flag For_Lib_Level must be set when creating - -- a master for a build-in-place function call access result type. Flag - -- For_Private must be set when the designated type contains a private - -- component. Parameters Context_Scope and Insertion_Node must be used in - -- conjunction with flags For_Anonymous and For_Private. Context_Scope is - -- the scope of the context where the finalization master must be analyzed. - -- Insertion_Node is the insertion point before which the master is to be - -- inserted. + -- the context. Flag For_Lib_Level must be set when creating a master for a + -- build-in-place function call access result type. Flag For_Private must + -- be set when the designated type contains a private component. Parameters + -- Context_Scope and Insertion_Node must be used in conjunction with flag + -- For_Private. Context_Scope is the scope of the context where the + -- finalization master must be analyzed. Insertion_Node is the insertion + -- point before which the master is to be inserted. procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); -- Build one controlling procedure when a late body overrides one of Index: einfo.adb =================================================================== --- einfo.adb (revision 235730) +++ einfo.adb (working copy) @@ -265,10 +265,9 @@ -- Contract Node34 + -- Anonymous_Master Node35 -- Import_Pragma Node35 - -- Anonymous_Master Node36 - -- Class_Wide_Preconds List38 -- Class_Wide_Postconds List39 @@ -757,12 +756,8 @@ function Anonymous_Master (Id : E) return E is begin - pragma Assert (Ekind_In (Id, E_Function, - E_Package, - E_Package_Body, - E_Procedure, - E_Subprogram_Body)); - return Node36 (Id); + pragma Assert (Is_Type (Id)); + return Node35 (Id); end Anonymous_Master; function Anonymous_Object (Id : E) return E is @@ -3682,12 +3677,8 @@ procedure Set_Anonymous_Master (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Function, - E_Package, - E_Package_Body, - E_Procedure, - E_Subprogram_Body)); - Set_Node36 (Id, V); + pragma Assert (Is_Type (Id)); + Set_Node35 (Id, V); end Set_Anonymous_Master; procedure Set_Anonymous_Object (Id : E; V : E) is @@ -10385,6 +10376,9 @@ procedure Write_Field35_Name (Id : Entity_Id) is begin case Ekind (Id) is + when Type_Kind => + Write_Str ("Anonymous_Master"); + when Subprogram_Kind => Write_Str ("Import_Pragma"); @@ -10398,19 +10392,9 @@ ------------------------ procedure Write_Field36_Name (Id : Entity_Id) is + pragma Unreferenced (Id); begin - case Ekind (Id) is - when E_Function | - E_Operator | - E_Package | - E_Package_Body | - E_Procedure | - E_Subprogram_Body => - Write_Str ("Anonymous_Master"); - - when others => - Write_Str ("Field36??"); - end case; + Write_Str ("Field36??"); end Write_Field36_Name; ------------------------ Index: einfo.ads =================================================================== --- einfo.ads (revision 235730) +++ einfo.ads (working copy) @@ -438,11 +438,11 @@ -- definition clause with an (obsolescent) mod clause is converted -- into an attribute definition clause for this purpose. --- Anonymous_Master (Node36) --- Defined in the entities of non-generic packages, subprograms and their --- corresponding bodies. Contains the entity of a special heterogeneous --- finalization master that services most anonymous access-to-controlled --- allocations that occur within the unit. +-- Anonymous_Master (Node35) +-- Defined in all types. Contains the entity of an anonymous finalization +-- master which services all anonymous access types associated with the +-- same designated type within the current semantic unit. The attribute +-- is set reactively during the expansion of allocators. -- Anonymous_Object (Node30) -- Present in protected and task type entities. Contains the entity of @@ -5468,6 +5468,7 @@ -- Derived_Type_Link (Node31) -- No_Tagged_Streams_Pragma (Node32) -- Linker_Section_Pragma (Node33) + -- Anonymous_Master (Node35) -- Depends_On_Private (Flag14) -- Disable_Controlled (Flag253) @@ -5668,8 +5669,8 @@ -- Cloned_Subtype (Node16) (subtype case only) -- First_Entity (Node17) -- Equivalent_Type (Node18) (always Empty for type) - -- Last_Entity (Node20) -- Non_Limited_View (Node19) + -- Last_Entity (Node20) -- SSO_Set_High_By_Default (Flag273) (base type only) -- SSO_Set_Low_By_Default (Flag272) (base type only) -- First_Component (synth) @@ -5919,7 +5920,6 @@ -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) - -- Anonymous_Master (Node36) (non-generic case only) -- Class_Wide_Preconds (List38) -- Class_Wide_Postconds (List39) -- SPARK_Pragma (Node40) @@ -6141,7 +6141,6 @@ -- Current_Use_Clause (Node27) -- Finalizer (Node28) (non-generic case only) -- Contract (Node34) - -- Anonymous_Master (Node36) (non-generic case only) -- SPARK_Pragma (Node40) -- SPARK_Aux_Pragma (Node41) -- Delay_Subprogram_Descriptors (Flag50) @@ -6179,7 +6178,6 @@ -- Scope_Depth_Value (Uint22) -- Finalizer (Node28) (non-generic case only) -- Contract (Node34) - -- Anonymous_Master (Node36) -- SPARK_Pragma (Node40) -- SPARK_Aux_Pragma (Node41) -- Contains_Ignored_Ghost_Code (Flag279) @@ -6233,7 +6231,6 @@ -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) - -- Anonymous_Master (Node36) (non-generic case only) -- Class_Wide_Preconds (List38) -- Class_Wide_Postconds (List39) -- SPARK_Pragma (Node40) @@ -6419,7 +6416,6 @@ -- Scope_Depth_Value (Uint22) -- Extra_Formals (Node28) -- Contract (Node34) - -- Anonymous_Master (Node36) -- SPARK_Pragma (Node40) -- Contains_Ignored_Ghost_Code (Flag279) -- SPARK_Pragma_Inherited (Flag265) Index: sem_util.adb =================================================================== --- sem_util.adb (revision 235729) +++ sem_util.adb (working copy) @@ -8322,6 +8322,73 @@ return Get_Pragma_Id (Pragma_Name (N)); end Get_Pragma_Id; + ------------------------ + -- Get_Qualified_Name -- + ------------------------ + + function Get_Qualified_Name + (Id : Entity_Id; + Suffix : Entity_Id := Empty) return Name_Id + is + Suffix_Nam : Name_Id := No_Name; + + begin + if Present (Suffix) then + Suffix_Nam := Chars (Suffix); + end if; + + return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id)); + end Get_Qualified_Name; + + function Get_Qualified_Name + (Nam : Name_Id; + Suffix : Name_Id := No_Name; + Scop : Entity_Id := Current_Scope) return Name_Id + is + procedure Add_Scope (S : Entity_Id); + -- Add the fully qualified form of scope S to the name buffer. The + -- format is: + -- s-1__s__ + + --------------- + -- Add_Scope -- + --------------- + + procedure Add_Scope (S : Entity_Id) is + begin + if S = Empty then + null; + + elsif S = Standard_Standard then + null; + + else + Add_Scope (Scope (S)); + Get_Name_String_And_Append (Chars (S)); + Add_Str_To_Name_Buffer ("__"); + end if; + end Add_Scope; + + -- Start of processing for Get_Qualified_Name + + begin + Name_Len := 0; + Add_Scope (Scop); + + -- Append the base name after all scopes have been chained + + Get_Name_String_And_Append (Nam); + + -- Append the suffix (if present) + + if Suffix /= No_Name then + Add_Str_To_Name_Buffer ("__"); + Get_Name_String_And_Append (Suffix); + end if; + + return Name_Find; + end Get_Qualified_Name; + ----------------------- -- Get_Reason_String -- ----------------------- @@ -17762,39 +17829,13 @@ ----------------- procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is - procedure Output_Scope (S : Entity_Id); - -- Add the fully qualified form of scope S to the name buffer. The - -- qualification format is: - -- scope1__scopeN__ - - ------------------ - -- Output_Scope -- - ------------------ - - procedure Output_Scope (S : Entity_Id) is - begin - if S = Empty then - null; - - elsif S = Standard_Standard then - null; - - else - Output_Scope (Scope (S)); - Add_Str_To_Name_Buffer (Get_Name_String (Chars (S))); - Add_Str_To_Name_Buffer ("__"); - end if; - end Output_Scope; - - -- Start of processing for Output_Name - begin - Name_Len := 0; - Output_Scope (Scop); - - Add_Str_To_Name_Buffer (Get_Name_String (Nam)); - - Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Str + (Get_Name_String + (Get_Qualified_Name + (Nam => Nam, + Suffix => No_Name, + Scop => Scop))); Write_Eol; end Output_Name; Index: sem_util.ads =================================================================== --- sem_util.ads (revision 235706) +++ sem_util.ads (working copy) @@ -950,6 +950,20 @@ pragma Inline (Get_Pragma_Id); -- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N) + function Get_Qualified_Name + (Id : Entity_Id; + Suffix : Entity_Id := Empty) return Name_Id; + -- Obtain the fully qualified form of entity Id. The format is: + -- scope_of_id-1__scope_of_id__chars_of_id__chars_of_suffix + + function Get_Qualified_Name + (Nam : Name_Id; + Suffix : Name_Id := No_Name; + Scop : Entity_Id := Current_Scope) return Name_Id; + -- Obtain the fully qualified form of name Nam assuming it appears in scope + -- Scop. The format is: + -- scop-1__scop__nam__suffix + procedure Get_Reason_String (N : Node_Id); -- Recursive routine to analyze reason argument for pragma Warnings. The -- value of the reason argument is appended to the current string using Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 235730) +++ exp_ch4.adb (working copy) @@ -44,7 +44,6 @@ with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Inline; use Inline; -with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -57,7 +56,6 @@ with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; -with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -92,12 +90,6 @@ -- If a boolean array assignment can be done in place, build call to -- corresponding library procedure. - function Current_Anonymous_Master return Entity_Id; - -- Return the entity of the heterogeneous finalization master belonging to - -- the current unit (either function, package or procedure). This master - -- services all anonymous access-to-controlled types. If the current unit - -- does not have such master, create one. - procedure Displace_Allocator_Pointer (N : Node_Id); -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and -- Expand_Allocator_Expression. Allocating class-wide interface objects @@ -410,202 +402,6 @@ return; end Build_Boolean_Array_Proc_Call; - ------------------------------ - -- Current_Anonymous_Master -- - ------------------------------ - - function Current_Anonymous_Master return Entity_Id is - function Create_Anonymous_Master - (Unit_Id : Entity_Id; - Unit_Decl : Node_Id) return Entity_Id; - -- Create a new anonymous master for a compilation unit denoted by its - -- entity Unit_Id and declaration Unit_Decl. The declaration of the new - -- master along with any specialized initialization is inserted at the - -- top of the unit's declarations (see body for special cases). Return - -- the entity of the anonymous master. - - ----------------------------- - -- Create_Anonymous_Master -- - ----------------------------- - - function Create_Anonymous_Master - (Unit_Id : Entity_Id; - Unit_Decl : Node_Id) return Entity_Id - is - Insert_Nod : Node_Id := Empty; - -- The point of insertion into the declarative list of the unit. All - -- nodes are inserted before Insert_Nod. - - procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id); - -- Insert arbitrary node N in declarative list Decls and analyze it - - ------------------------ - -- Insert_And_Analyze -- - ------------------------ - - procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id) is - begin - -- The declarative list is already populated, the nodes are - -- inserted at the top of the list, preserving their order. - - if Present (Insert_Nod) then - Insert_Before (Insert_Nod, N); - - -- Otherwise append to the declarations to preserve order - - else - Append_To (Decls, N); - end if; - - Analyze (N); - end Insert_And_Analyze; - - -- Local variables - - Loc : constant Source_Ptr := Sloc (Unit_Id); - Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl); - Decls : List_Id; - FM_Id : Entity_Id; - Pref : Character; - Unit_Spec : Node_Id; - - -- Start of processing for Create_Anonymous_Master - - begin - -- Find the declarative list of the unit - - if Nkind (Unit_Decl) = N_Package_Declaration then - Unit_Spec := Specification (Unit_Decl); - Decls := Visible_Declarations (Unit_Spec); - - if No (Decls) then - Decls := New_List (Make_Null_Statement (Loc)); - Set_Visible_Declarations (Unit_Spec, Decls); - end if; - - -- Package or subprogram body - - -- ??? A subprogram declaration that acts as a compilation unit may - -- contain a formal parameter of an anonymous access-to-controlled - -- type initialized by an allocator. - - -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl); - - -- There is no suitable place to create the anonymous master as the - -- subprogram is not in a declarative list. - - else - Decls := Declarations (Unit_Decl); - - if No (Decls) then - Decls := New_List (Make_Null_Statement (Loc)); - Set_Declarations (Unit_Decl, Decls); - end if; - end if; - - -- The anonymous master and all initialization actions are inserted - -- before the first declaration (if any). - - Insert_Nod := First (Decls); - - -- Since the anonymous master and all its initialization actions are - -- inserted at top level, use the scope of the unit when analyzing. - - Push_Scope (Spec_Id); - - -- Step 1: Anonymous master creation - - -- Use a unique prefix in case the same unit requires two anonymous - -- masters, one for the spec (S) and one for the body (B). - - if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then - Pref := 'S'; - else - Pref := 'B'; - end if; - - FM_Id := - Make_Defining_Identifier (Loc, - New_External_Name - (Related_Id => Chars (Unit_Id), - Suffix => "AM", - Prefix => Pref)); - - Set_Anonymous_Master (Unit_Id, FM_Id); - - -- Generate: - -- : Finalization_Master; - - Insert_And_Analyze (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => FM_Id, - Object_Definition => - New_Occurrence_Of (RTE (RE_Finalization_Master), Loc))); - - -- Step 2: Initialization actions - - -- Generate: - -- Set_Base_Pool - -- (, Global_Pool_Object'Unrestricted_Access); - - Insert_And_Analyze (Decls, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (FM_Id, Loc), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc), - Attribute_Name => Name_Unrestricted_Access)))); - - -- Generate: - -- Set_Is_Heterogeneous (); - - Insert_And_Analyze (Decls, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (FM_Id, Loc)))); - - Pop_Scope; - return FM_Id; - end Create_Anonymous_Master; - - -- Local declarations - - Unit_Decl : Node_Id; - Unit_Id : Entity_Id; - - -- Start of processing for Current_Anonymous_Master - - begin - Unit_Decl := Unit (Cunit (Current_Sem_Unit)); - Unit_Id := Defining_Entity (Unit_Decl); - - -- The compilation unit is a package instantiation. In this case the - -- anonymous master is associated with the package spec as both the - -- spec and body appear at the same level. - - if Nkind (Unit_Decl) = N_Package_Body - and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation - then - Unit_Id := Corresponding_Spec (Unit_Decl); - Unit_Decl := Unit_Declaration_Node (Unit_Id); - end if; - - if Present (Anonymous_Master (Unit_Id)) then - return Anonymous_Master (Unit_Id); - - -- Create a new anonymous master when allocating an object of anonymous - -- access-to-controlled type for the first time. - - else - return Create_Anonymous_Master (Unit_Id, Unit_Decl); - end if; - end Current_Anonymous_Master; - -------------------------------- -- Displace_Allocator_Pointer -- -------------------------------- @@ -4296,8 +4092,7 @@ Set_Finalization_Master (Root_Type (PtrT), Finalization_Master (Rel_Typ)); else - Set_Finalization_Master - (Root_Type (PtrT), Current_Anonymous_Master); + Build_Anonymous_Master (Root_Type (PtrT)); end if; end if; Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 235706) +++ exp_ch6.adb (working copy) @@ -422,11 +422,7 @@ if Ekind (Ptr_Typ) = E_Anonymous_Access_Type and then No (Finalization_Master (Ptr_Typ)) then - Build_Finalization_Master - (Typ => Ptr_Typ, - For_Anonymous => True, - Context_Scope => Scope (Ptr_Typ), - Insertion_Node => Associated_Node_For_Itype (Ptr_Typ)); + Build_Anonymous_Master (Ptr_Typ); end if; -- Access-to-controlled types should always have a master Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 235730) +++ exp_ch3.adb (working copy) @@ -4600,8 +4600,6 @@ Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; - Ins_Node : Node_Id; - begin -- Ensure that all freezing activities are properly flagged as Ghost @@ -4654,39 +4652,13 @@ end if; end if; - if Typ = Base then - if Has_Controlled_Component (Base) then - Build_Controlling_Procs (Base); + if Typ = Base and then Has_Controlled_Component (Base) then + Build_Controlling_Procs (Base); - if not Is_Limited_Type (Comp_Typ) - and then Number_Dimensions (Typ) = 1 - then - Build_Slice_Assignment (Typ); - end if; - end if; - - -- Create a finalization master to service the anonymous access - -- components of the array. - - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) + if not Is_Limited_Type (Comp_Typ) + and then Number_Dimensions (Typ) = 1 then - -- The finalization master is inserted before the declaration - -- of the array type. The only exception to this is when the - -- array type is an itype, in which case the master appears - -- before the related context. - - if Is_Itype (Typ) then - Ins_Node := Associated_Node_For_Itype (Typ); - else - Ins_Node := Parent (Typ); - end if; - - Build_Finalization_Master - (Typ => Comp_Typ, - For_Anonymous => True, - Context_Scope => Scope (Typ), - Insertion_Node => Ins_Node); + Build_Slice_Assignment (Typ); end if; end if; @@ -5044,13 +5016,12 @@ Append_To (Lst, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List ( + Statements => New_List ( Make_Raise_Constraint_Error (Loc, Condition => Make_Identifier (Loc, Name_uF), Reason => CE_Invalid_Data), Make_Simple_Return_Statement (Loc, - Expression => - Make_Integer_Literal (Loc, -1))))); + Expression => Make_Integer_Literal (Loc, -1))))); -- If either of the restrictions No_Exceptions_Handlers/Propagation is -- active then return -1 (we cannot usefully raise Constraint_Error in @@ -5060,10 +5031,9 @@ Append_To (Lst, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List ( + Statements => New_List ( Make_Simple_Return_Statement (Loc, - Expression => - Make_Integer_Literal (Loc, -1))))); + Expression => Make_Integer_Literal (Loc, -1))))); end if; -- Now we can build the function body @@ -5137,9 +5107,11 @@ Comp : Entity_Id; Comp_Typ : Entity_Id; - Has_AACC : Boolean; Predef_List : List_Id; + Wrapper_Decl_List : List_Id := No_List; + Wrapper_Body_List : List_Id := No_List; + Renamed_Eq : Node_Id := Empty; -- Defining unit name for the predefined equality function in the case -- where the type has a primitive operation that is a renaming of @@ -5147,9 +5119,6 @@ -- user-defined equality function). Used to pass this entity from -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. - Wrapper_Decl_List : List_Id := No_List; - Wrapper_Body_List : List_Id := No_List; - -- Start of processing for Expand_Freeze_Record_Type begin @@ -5212,8 +5181,6 @@ -- of the component types may have been private at the point of the -- record declaration. Detect anonymous access-to-controlled components. - Has_AACC := False; - Comp := First_Component (Typ); while Present (Comp) loop Comp_Typ := Etype (Comp); @@ -5238,15 +5205,6 @@ Set_Has_Controlled_Component (Typ); end if; - -- Non-self-referential anonymous access-to-controlled component - - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) - and then Designated_Type (Comp_Typ) /= Typ - then - Has_AACC := True; - end if; - Next_Component (Comp); end loop; @@ -5595,97 +5553,6 @@ end; end if; - -- Create a heterogeneous finalization master to service the anonymous - -- access-to-controlled components of the record type. - - if Has_AACC then - declare - Encl_Scope : constant Entity_Id := Scope (Typ); - Ins_Node : constant Node_Id := Parent (Typ); - Loc : constant Source_Ptr := Sloc (Typ); - Fin_Mas_Id : Entity_Id; - - Attributes_Set : Boolean := False; - Master_Built : Boolean := False; - -- Two flags which control the creation and initialization of a - -- common heterogeneous master. - - begin - Comp := First_Component (Typ); - while Present (Comp) loop - Comp_Typ := Etype (Comp); - - -- A non-self-referential anonymous access-to-controlled - -- component. - - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) - and then Designated_Type (Comp_Typ) /= Typ - then - -- Build a homogeneous master for the first anonymous - -- access-to-controlled component. This master may be - -- converted into a heterogeneous collection if more - -- components are to follow. - - if not Master_Built then - Master_Built := True; - - -- All anonymous access-to-controlled types allocate - -- on the global pool. Note that the finalization - -- master and the associated storage pool must be set - -- on the root type (both are "root type only"). - - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - - Build_Finalization_Master - (Typ => Root_Type (Comp_Typ), - For_Anonymous => True, - Context_Scope => Encl_Scope, - Insertion_Node => Ins_Node); - - Fin_Mas_Id := Finalization_Master (Comp_Typ); - - -- Subsequent anonymous access-to-controlled components - -- reuse the available master. - - else - -- All anonymous access-to-controlled types allocate - -- on the global pool. Note that both the finalization - -- master and the associated storage pool must be set - -- on the root type (both are "root type only"). - - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - - -- Shared the master among multiple components - - Set_Finalization_Master - (Root_Type (Comp_Typ), Fin_Mas_Id); - - -- Convert the master into a heterogeneous collection. - -- Generate: - -- Set_Is_Heterogeneous (); - - if not Attributes_Set then - Attributes_Set := True; - - Insert_Action (Ins_Node, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Set_Is_Heterogeneous), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Fin_Mas_Id, Loc)))); - end if; - end if; - end if; - - Next_Component (Comp); - end loop; - end; - end if; - -- Check whether individual components have a defined invariant, and add -- the corresponding component invariant checks.