From 5b42c03538d0c0ce1c37e85855b6c18238fb1463 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 12 Oct 2016 15:59:48 +0200 Subject: [PATCH] [multiple changes] 2016-10-12 Hristian Kirtchev * einfo.adb Add new usage for Elist29 and Node35. (Anonymous_Designated_Type): New routine. (Anonymous_Master): Removed. (Anonymous_Masters): New routine. (Set_Anonymous_Designated_Type): New routine. (Set_Anonymous_Master): Removed. (Set_Anonymous_Masters): New routine. (Write_Field29_Name): Add output for Anonymous_Masters. (Write_Field35_Name): Remove the output for Anonymous_Master. Add output for Anonymous_Designated_Type. * einfo.ads Remove attribute Anonymous_Master along with usage in entities. Add attributes Anonymous_Designated_Type and Anonymous_Masters along with usage in entities. (Anonymous_Designated_Type): New routine along with pragma Inline. (Anonymous_Master): Removed along with pragma Inline. (Anonymous_Masters): New routine along with pragma Inline. (Set_Anonymous_Designated_Type): New routine along with pragma Inline. (Set_Anonymous_Master): Removed along with pragma Inline. (Set_Anonymous_Masters): New routine along with pragma Inline. * exp_ch7.adb (Build_Anonymous_Master): Reuse an anonymous master defined in the same unit if it services the same designated type, otherwise create a new one. (Create_Anonymous_Master): Reimplemented. (Current_Anonymous_Master): New routine. (In_Subtree): Removed. 2016-10-12 Ed Schonberg * sem_prag.adb (Analyze_Pragma, case Dynamic_Predicate): Check properly whether there is an explicit assertion policy for predicate checking, even in the presence of a general Ignore assertion policy. 2016-10-12 Steve Baird * sem.adb (Walk_Library_Items): Cope with ignored ghost units. From-SVN: r241049 --- gcc/ada/ChangeLog | 39 ++++++++++ gcc/ada/einfo.adb | 43 ++++++++--- gcc/ada/einfo.ads | 32 ++++++--- gcc/ada/exp_ch7.adb | 197 +++++++++++++++++++++++++-------------------------- gcc/ada/sem.adb | 10 +++ gcc/ada/sem_prag.adb | 10 +-- 6 files changed, 207 insertions(+), 124 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index db7b6c8..d47f3d1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,42 @@ +2016-10-12 Hristian Kirtchev + + * einfo.adb Add new usage for Elist29 and Node35. + (Anonymous_Designated_Type): New routine. + (Anonymous_Master): Removed. + (Anonymous_Masters): New routine. + (Set_Anonymous_Designated_Type): New routine. + (Set_Anonymous_Master): Removed. + (Set_Anonymous_Masters): New routine. + (Write_Field29_Name): Add output for Anonymous_Masters. + (Write_Field35_Name): Remove the output for Anonymous_Master. Add + output for Anonymous_Designated_Type. + * einfo.ads Remove attribute Anonymous_Master along with + usage in entities. Add attributes Anonymous_Designated_Type + and Anonymous_Masters along with usage in entities. + (Anonymous_Designated_Type): New routine along with pragma Inline. + (Anonymous_Master): Removed along with pragma Inline. + (Anonymous_Masters): New routine along with pragma Inline. + (Set_Anonymous_Designated_Type): New routine along with pragma Inline. + (Set_Anonymous_Master): Removed along with pragma Inline. + (Set_Anonymous_Masters): New routine along with pragma Inline. + * exp_ch7.adb (Build_Anonymous_Master): Reuse an anonymous master + defined in the same unit if it services the same designated + type, otherwise create a new one. + (Create_Anonymous_Master): Reimplemented. + (Current_Anonymous_Master): New routine. + (In_Subtree): Removed. + +2016-10-12 Ed Schonberg + + * sem_prag.adb (Analyze_Pragma, case Dynamic_Predicate): + Check properly whether there is an explicit assertion policy + for predicate checking, even in the presence of a general Ignore + assertion policy. + +2016-10-12 Steve Baird + + * sem.adb (Walk_Library_Items): Cope with ignored ghost units. + 2016-10-12 Ed Schonberg * lib-writ.adb (Write_ALI): Removal of unused file entries from diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index dedc8a3..83eddf3 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -244,6 +244,7 @@ package body Einfo is -- Relative_Deadline_Variable Node28 -- Underlying_Record_View Node28 + -- Anonymous_Masters Elist29 -- BIP_Initialization_Call Node29 -- Subprograms_For_Type Elist29 @@ -265,7 +266,7 @@ package body Einfo is -- Contract Node34 - -- Anonymous_Master Node35 + -- Anonymous_Designated_Type Node35 -- Import_Pragma Node35 -- Class_Wide_Preconds List38 @@ -766,11 +767,20 @@ package body Einfo is return Uint14 (Id); end Alignment; - function Anonymous_Master (Id : E) return E is + function Anonymous_Designated_Type (Id : E) return E is begin - pragma Assert (Is_Type (Id)); + pragma Assert (Ekind (Id) = E_Variable); return Node35 (Id); - end Anonymous_Master; + end Anonymous_Designated_Type; + + function Anonymous_Masters (Id : E) return L is + begin + pragma Assert (Ekind_In (Id, E_Function, + E_Package, + E_Procedure, + E_Subprogram_Body)); + return Elist29 (Id); + end Anonymous_Masters; function Anonymous_Object (Id : E) return E is begin @@ -3726,11 +3736,20 @@ package body Einfo is Set_Elist16 (Id, V); end Set_Access_Disp_Table; - procedure Set_Anonymous_Master (Id : E; V : E) is + procedure Set_Anonymous_Designated_Type (Id : E; V : E) is begin - pragma Assert (Is_Type (Id)); + pragma Assert (Ekind (Id) = E_Variable); Set_Node35 (Id, V); - end Set_Anonymous_Master; + end Set_Anonymous_Designated_Type; + + procedure Set_Anonymous_Masters (Id : E; V : L) is + begin + pragma Assert (Ekind_In (Id, E_Function, + E_Package, + E_Procedure, + E_Subprogram_Body)); + Set_Elist29 (Id, V); + end Set_Anonymous_Masters; procedure Set_Anonymous_Object (Id : E; V : E) is begin @@ -10503,6 +10522,12 @@ package body Einfo is procedure Write_Field29_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Function | + E_Package | + E_Procedure | + E_Subprogram_Body => + Write_Str ("Anonymous_Masters"); + when E_Constant | E_Variable => Write_Str ("BIP_Initialization_Call"); @@ -10650,8 +10675,8 @@ package body Einfo is procedure Write_Field35_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Type_Kind => - Write_Str ("Anonymous_Master"); + when E_Variable => + Write_Str ("Anonymous_Designated_Type"); when Subprogram_Kind => Write_Str ("Import_Pragma"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 405d978..9ffc2a8 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -438,11 +438,15 @@ package Einfo is -- definition clause with an (obsolescent) mod clause is converted -- into an attribute definition clause for this purpose. --- 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_Designated_Type (Node35) +-- Defined in variables which represent anonymous finalization masters. +-- Contains the designated type which is being services by the master. + +-- Anonymous_Masters (Elist29) +-- Defined in packages, subprograms, and subprogram bodies. Contains a +-- list of anonymous finalization masters declared within the related +-- unit. The list acts as a mapping between a master and a designated +-- type. -- Anonymous_Object (Node30) -- Present in protected and task type entities. Contains the entity of @@ -5530,7 +5534,6 @@ package Einfo is -- Derived_Type_Link (Node31) -- No_Tagged_Streams_Pragma (Node32) -- Linker_Section_Pragma (Node33) - -- Anonymous_Master (Node35) -- Depends_On_Private (Flag14) -- Disable_Controlled (Flag253) @@ -5982,6 +5985,7 @@ package Einfo is -- Overridden_Operation (Node26) -- Wrapped_Entity (Node27) (non-generic case only) -- Extra_Formals (Node28) + -- Anonymous_Masters (Elist29) (non-generic case only) -- Corresponding_Equality (Node30) (implicit /= only) -- Thunk_Entity (Node31) (thunk case only) -- Corresponding_Procedure (Node32) (generate C code only) @@ -6207,6 +6211,7 @@ package Einfo is -- Package_Instantiation (Node26) -- Current_Use_Clause (Node27) -- Finalizer (Node28) (non-generic case only) + -- Anonymous_Masters (Elist29) (non-generic case only) -- Contract (Node34) -- SPARK_Pragma (Node40) -- SPARK_Aux_Pragma (Node41) @@ -6292,6 +6297,7 @@ package Einfo is -- Overridden_Operation (Node26) (never for init proc) -- Wrapped_Entity (Node27) (non-generic case only) -- Extra_Formals (Node28) + -- Anonymous_Masters (Elist29) (non-generic case only) -- Static_Initialization (Node30) (init_proc only) -- Thunk_Entity (Node31) (thunk case only) -- Corresponding_Function (Node32) (generate C code only) @@ -6483,6 +6489,7 @@ package Einfo is -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) -- Extra_Formals (Node28) + -- Anonymous_Masters (Elist29) -- Contract (Node34) -- SPARK_Pragma (Node40) -- Contains_Ignored_Ghost_Code (Flag279) @@ -6564,6 +6571,7 @@ package Einfo is -- Encapsulating_State (Node32) -- Linker_Section_Pragma (Node33) -- Contract (Node34) + -- Anonymous_Designated_Type (Node35) -- SPARK_Pragma (Node40) -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) @@ -6837,7 +6845,8 @@ package Einfo is function Address_Taken (Id : E) return B; function Alias (Id : E) return E; function Alignment (Id : E) return U; - function Anonymous_Master (Id : E) return E; + function Anonymous_Designated_Type (Id : E) return E; + function Anonymous_Masters (Id : E) return L; function Anonymous_Object (Id : E) return E; function Associated_Entity (Id : E) return E; function Associated_Formal_Package (Id : E) return E; @@ -7516,7 +7525,8 @@ package Einfo is procedure Set_Address_Taken (Id : E; V : B := True); procedure Set_Alias (Id : E; V : E); procedure Set_Alignment (Id : E; V : U); - procedure Set_Anonymous_Master (Id : E; V : E); + procedure Set_Anonymous_Designated_Type (Id : E; V : E); + procedure Set_Anonymous_Masters (Id : E; V : L); procedure Set_Anonymous_Object (Id : E; V : E); procedure Set_Associated_Entity (Id : E; V : E); procedure Set_Associated_Formal_Package (Id : E; V : E); @@ -8314,7 +8324,8 @@ package Einfo is pragma Inline (Address_Taken); pragma Inline (Alias); pragma Inline (Alignment); - pragma Inline (Anonymous_Master); + pragma Inline (Anonymous_Designated_Type); + pragma Inline (Anonymous_Masters); pragma Inline (Anonymous_Object); pragma Inline (Associated_Entity); pragma Inline (Associated_Formal_Package); @@ -8832,7 +8843,8 @@ package Einfo is pragma Inline (Set_Address_Taken); pragma Inline (Set_Alias); pragma Inline (Set_Alignment); - pragma Inline (Set_Anonymous_Master); + pragma Inline (Set_Anonymous_Designated_Type); + pragma Inline (Set_Anonymous_Masters); pragma Inline (Set_Anonymous_Object); pragma Inline (Set_Associated_Entity); pragma Inline (Set_Associated_Formal_Package); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 2338deb..bd46955 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -541,14 +541,16 @@ package body Exp_Ch7 is (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. + -- Create a new anonymous master for access type Ptr_Typ with designated + -- type Desig_Typ. The declaration of the master and its initialization + -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is + -- 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. + function Current_Anonymous_Master + (Desig_Typ : Entity_Id; + Unit_Id : Entity_Id) return Entity_Id; + -- Find an anonymous master declared within unit Unit_Id which services + -- designated type Desig_Typ. If there is no such master, return Empty. ----------------------------- -- Create_Anonymous_Master -- @@ -559,16 +561,42 @@ package body Exp_Ch7 is 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); + Loc : constant Source_Ptr := Sloc (Unit_Id); + + All_FMs : Elist_Id; Decls : List_Id; FM_Decl : Node_Id; FM_Id : Entity_Id; FM_Init : Node_Id; - Pref : Character; Unit_Spec : Node_Id; begin + -- Generate: + -- : Finalization_Master; + + FM_Id := Make_Temporary (Loc, 'A'); + + FM_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => FM_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)); + + -- 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))); + -- Find the declarative list of the unit if Nkind (Unit_Decl) = N_Package_Declaration then @@ -588,8 +616,8 @@ package body Exp_Ch7 is -- 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. + -- There is no suitable place to create the master as the subprogram + -- is not in a declarative list. else Decls := Declarations (Unit_Decl); @@ -600,100 +628,74 @@ package body Exp_Ch7 is 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 master within the - -- same unit. - - Set_Anonymous_Master (Desig_Typ, FM_Id); + Prepend_To (Decls, FM_Init); + Prepend_To (Decls, FM_Decl); - -- Generate: - -- : Finalization_Master; + -- Use the scope of the unit when analyzing the declaration of the + -- master and its initialization actions. - FM_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => FM_Id, - Object_Definition => - New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)); + Push_Scope (Unit_Id); + Analyze (FM_Decl); + Analyze (FM_Init); + Pop_Scope; - -- Step 2: Initialization actions + -- Mark the master as servicing this specific designated type - -- Generate: - -- Set_Base_Pool - -- (, Global_Pool_Object'Unrestricted_Access); + Set_Anonymous_Designated_Type (FM_Id, Desig_Typ); - 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))); + -- Include the anonymous master in the list of existing masters which + -- appear in this unit. This effectively creates a mapping between a + -- master and a designated type which in turn allows for the reusal + -- of masters on a per-unit basis. - Prepend_To (Decls, FM_Init); - Prepend_To (Decls, FM_Decl); + All_FMs := Anonymous_Masters (Unit_Id); - -- Since the anonymous master and all its initialization actions are - -- inserted at top level, use the scope of the unit when analyzing. + if No (All_FMs) then + All_FMs := New_Elmt_List; + Set_Anonymous_Masters (Unit_Id, All_FMs); + end if; - Push_Scope (Spec_Id); - Analyze (FM_Decl); - Analyze (FM_Init); - Pop_Scope; + Prepend_Elmt (FM_Id, All_FMs); return FM_Id; end Create_Anonymous_Master; - ---------------- - -- In_Subtree -- - ---------------- + ------------------------------ + -- Current_Anonymous_Master -- + ------------------------------ - function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is - Par : Node_Id; + function Current_Anonymous_Master + (Desig_Typ : Entity_Id; + Unit_Id : Entity_Id) return Entity_Id + is + All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id); + FM_Elmt : Elmt_Id; + FM_Id : Entity_Id; begin - -- Traverse the parent chain until reaching the same root + -- Inspect the list of anonymous masters declared within the unit + -- looking for an existing master which services the same designated + -- type. - Par := N; - while Present (Par) loop - if Par = Root then - return True; - end if; + if Present (All_FMs) then + FM_Elmt := First_Elmt (All_FMs); + while Present (FM_Elmt) loop + FM_Id := Node (FM_Elmt); - Par := Parent (Par); - end loop; + -- The currect master services the same designated type. As a + -- result the master can be reused and associated with another + -- anonymous access-to-controlled type. - return False; - end In_Subtree; + if Anonymous_Designated_Type (FM_Id) = Desig_Typ then + return FM_Id; + end if; + + Next_Elmt (FM_Elmt); + end loop; + end if; + + return Empty; + end Current_Anonymous_Master; -- Local variables @@ -714,7 +716,7 @@ package body Exp_Ch7 is end if; Unit_Decl := Unit (Cunit (Current_Sem_Unit)); - Unit_Id := Defining_Entity (Unit_Decl); + Unit_Id := Unique_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 @@ -738,21 +740,14 @@ package body Exp_Ch7 is Desig_Typ := Priv_View; end if; - FM_Id := Anonymous_Master (Desig_Typ); + -- Determine whether the current semantic unit already has an anonymous + -- master which services the designated type. - -- 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. + FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id); - if Present (FM_Id) - and then In_Subtree (Declaration_Node (FM_Id), Root => Unit_Decl) - then - null; + -- If this is not the case, create a new master - -- Otherwise the designated type lacks an anonymous master or it is - -- declared in a different unit. Create a brand new master. - - else + if No (FM_Id) then FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl); end if; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 7a86644..6e8ab45 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1767,6 +1767,11 @@ package body Sem is pragma Assert (False, "subunit"); null; + when N_Null_Statement => + pragma Assert (Is_Ignored_Ghost_Node (Original_Node (Item))); + -- Do not call Action for an ignored ghost unit + return; + when others => pragma Assert (False); null; @@ -2095,6 +2100,11 @@ package body Sem is -- happen when the body of a parent depends on some other -- descendant. + when N_Null_Statement => + -- Ignore an ignored ghost unit + pragma Assert (Is_Ignored_Ghost_Node (Original_Node (N))); + null; + when others => Par := Scope (Defining_Entity (Unit (CU))); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9b9fe82..545b43d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -19136,15 +19136,17 @@ package body Sem_Prag is -- the rep item chain, for processing when the type is frozen. -- This is accomplished by a call to Rep_Item_Too_Late. We also -- mark the type as having predicates. - -- If the current policy is Ignore mark the subtype accordingly. - -- In the case of predicates we consider them enabled unless an - -- Ignore is specified, to preserve existing warnings. + + -- If the current policy for predicate checking is Ignore mark the + -- subtype accordingly. In the case of predicates we consider them + -- enabled unless Ignore is specified (either directly or with a + -- general Assertion_Policy pragma) to preserve existing warnings. Set_Has_Predicates (Typ); Set_Predicates_Ignored (Typ, Present (Check_Policy_List) and then - Policy_In_Effect (Name_Assertion_Policy) = Name_Ignore); + Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore); Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); end Predicate; -- 2.7.4