===================================================================
@@ -264,7 +264,8 @@
-- Import_Pragma Node35
- -- (unused) Node36
+ -- Anonymous_Master Node36
+
-- (unused) Node38
-- (unused) Node39
-- (unused) Node40
@@ -556,7 +557,6 @@
-- Has_Implicit_Dereference Flag251
-- Is_Processed_Transient Flag252
- -- Has_Anonymous_Master Flag253
-- Is_Implementation_Defined Flag254
-- Is_Predicate_Function Flag255
-- Is_Predicate_Function_M Flag256
@@ -594,6 +594,7 @@
-- Has_Volatile_Full_Access Flag285
-- Needs_Typedef Flag286
+ -- (unused) Flag253
-- (unused) Flag287
-- (unused) Flag288
-- (unused) Flag289
@@ -753,6 +754,12 @@
return Uint14 (Id);
end Alignment;
+ function Anonymous_Master (Id : E) return E is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Package, E_Procedure));
+ return Node36 (Id);
+ end Anonymous_Master;
+
function Associated_Entity (Id : E) return E is
begin
return Node37 (Id);
@@ -1375,13 +1382,6 @@
return Flag79 (Id);
end Has_All_Calls_Remote;
- function Has_Anonymous_Master (Id : E) return B is
- begin
- pragma Assert
- (Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure));
- return Flag253 (Id);
- end Has_Anonymous_Master;
-
function Has_Atomic_Components (Id : E) return B is
begin
return Flag86 (Implementation_Base_Type (Id));
@@ -3576,6 +3576,12 @@
Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
+ procedure Set_Anonymous_Master (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Package, E_Procedure));
+ Set_Node36 (Id, V);
+ end Set_Anonymous_Master;
+
procedure Set_Associated_Entity (Id : E; V : E) is
begin
Set_Node37 (Id, V);
@@ -4246,13 +4252,6 @@
Set_Flag79 (Id, V);
end Set_Has_All_Calls_Remote;
- procedure Set_Has_Anonymous_Master (Id : E; V : B := True) is
- begin
- pragma Assert
- (Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure));
- Set_Flag253 (Id, V);
- end Set_Has_Anonymous_Master;
-
procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
begin
pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
@@ -8634,7 +8633,6 @@
W ("Has_Aliased_Components", Flag135 (Id));
W ("Has_Alignment_Clause", Flag46 (Id));
W ("Has_All_Calls_Remote", Flag79 (Id));
- W ("Has_Anonymous_Master", Flag253 (Id));
W ("Has_Atomic_Components", Flag86 (Id));
W ("Has_Biased_Representation", Flag139 (Id));
W ("Has_Completion", Flag26 (Id));
@@ -10121,6 +10119,12 @@
procedure Write_Field36_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Function |
+ E_Operator |
+ E_Package |
+ E_Procedure =>
+ Write_Str ("Anonymous_Master");
+
when others =>
Write_Str ("Field36??");
end case;
===================================================================
@@ -436,6 +436,12 @@
-- 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 subprogram and package units.
+-- Contains the entity of a special heterogeneous finalization master
+-- that services most anonymous access-to-controlled allocations that
+-- occur within the unit.
+
-- Associated_Entity (Node37)
-- Defined in all entities. This field is similar to Associated_Node, but
-- applied to entities. The attribute links an entity from the generic
@@ -1423,13 +1429,6 @@
-- entities, so the flag Is_Remote_Call_Interface will always be set if
-- this flag is set.
-
-- Has_Atomic_Components (Flag86) [implementation base type only]
-- Defined in all types and objects. Set only for an array type or
-- an array object if a valid pragma Atomic_Components applies to the
@@ -5833,6 +5832,7 @@
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
+ -- Anonymous_Master (Node36) (non-generic case only)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Default_Expressions_Processed (Flag108)
@@ -5840,7 +5840,6 @@
-- Delay_Subprogram_Descriptors (Flag50)
-- Discard_Names (Flag88)
-- Elaboration_Entity_Required (Flag174)
- -- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Controlling_Result (Flag98)
-- Has_Expanded_Contract (Flag240) (non-generic case only)
@@ -6050,6 +6049,7 @@
-- SPARK_Pragma (Node32)
-- SPARK_Aux_Pragma (Node33)
-- Contract (Node34)
+ -- Anonymous_Master (Node36) (non-generic case only)
-- Delay_Subprogram_Descriptors (Flag50)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
@@ -6058,7 +6058,6 @@
-- Elaborate_Body_Desirable (Flag210) (non-generic case only)
-- From_Limited_With (Flag159)
-- Has_All_Calls_Remote (Flag79)
- -- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Forward_Instantiation (Flag175)
-- Has_Master_Entity (Flag21)
@@ -6089,7 +6088,6 @@
-- Contract (Node34)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Delay_Subprogram_Descriptors (Flag50)
- -- Has_Anonymous_Master (Flag253)
-- SPARK_Aux_Pragma_Inherited (Flag266)
-- SPARK_Pragma_Inherited (Flag265)
-- Scope_Depth (synth)
@@ -6139,6 +6137,7 @@
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
+ -- Anonymous_Master (Node36) (non-generic case only)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Delay_Cleanups (Flag114)
@@ -6148,7 +6147,6 @@
-- Delay_Cleanups (Flag114)
-- Delay_Subprogram_Descriptors (Flag50)
-- Discard_Names (Flag88)
- -- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Expanded_Contract (Flag240) (non-generic case only)
-- Has_Invariants (Flag232)
@@ -6647,6 +6645,7 @@
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 Associated_Entity (Id : E) return E;
function Associated_Formal_Package (Id : E) return E;
function Associated_Node_For_Itype (Id : E) return N;
@@ -6750,7 +6749,6 @@
function Has_Aliased_Components (Id : E) return B;
function Has_Alignment_Clause (Id : E) return B;
function Has_All_Calls_Remote (Id : E) return B;
- function Has_Anonymous_Master (Id : E) return B;
function Has_Atomic_Components (Id : E) return B;
function Has_Biased_Representation (Id : E) return B;
function Has_Completion (Id : E) return B;
@@ -7301,6 +7299,7 @@
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_Associated_Entity (Id : E; V : E);
procedure Set_Associated_Formal_Package (Id : E; V : E);
procedure Set_Associated_Node_For_Itype (Id : E; V : N);
@@ -7403,7 +7402,6 @@
procedure Set_Has_Aliased_Components (Id : E; V : B := True);
procedure Set_Has_Alignment_Clause (Id : E; V : B := True);
procedure Set_Has_All_Calls_Remote (Id : E; V : B := True);
- procedure Set_Has_Anonymous_Master (Id : E; V : B := True);
procedure Set_Has_Atomic_Components (Id : E; V : B := True);
procedure Set_Has_Biased_Representation (Id : E; V : B := True);
procedure Set_Has_Completion (Id : E; V : B := True);
@@ -8076,6 +8074,7 @@
pragma Inline (Address_Taken);
pragma Inline (Alias);
pragma Inline (Alignment);
+ pragma Inline (Anonymous_Master);
pragma Inline (Associated_Entity);
pragma Inline (Associated_Formal_Package);
pragma Inline (Associated_Node_For_Itype);
@@ -8176,7 +8175,6 @@
pragma Inline (Has_Aliased_Components);
pragma Inline (Has_Alignment_Clause);
pragma Inline (Has_All_Calls_Remote);
- pragma Inline (Has_Anonymous_Master);
pragma Inline (Has_Atomic_Components);
pragma Inline (Has_Biased_Representation);
pragma Inline (Has_Completion);
@@ -8577,6 +8575,7 @@
pragma Inline (Set_Address_Taken);
pragma Inline (Set_Alias);
pragma Inline (Set_Alignment);
+ pragma Inline (Set_Anonymous_Master);
pragma Inline (Set_Associated_Entity);
pragma Inline (Set_Associated_Formal_Package);
pragma Inline (Set_Associated_Node_For_Itype);
@@ -8675,7 +8674,6 @@
pragma Inline (Set_Has_Aliased_Components);
pragma Inline (Set_Has_Alignment_Clause);
pragma Inline (Set_Has_All_Calls_Remote);
- pragma Inline (Set_Has_Anonymous_Master);
pragma Inline (Set_Has_Atomic_Components);
pragma Inline (Set_Has_Biased_Representation);
pragma Inline (Set_Has_Completion);
===================================================================
@@ -415,174 +415,164 @@
------------------------------
function Current_Anonymous_Master return Entity_Id is
- Decls : List_Id;
- Loc : Source_Ptr;
- Subp_Body : Node_Id;
- Unit_Decl : Node_Id;
- Unit_Id : Entity_Id;
+ function Create_Anonymous_Master
+ (Unit_Id : Entity_Id;
+ Decls : List_Id) return Entity_Id;
+ -- Create a new anonymous finalization master for a unit denoted by
+ -- Unit_Id. The declaration of the master along with any specialized
+ -- initialization is inserted at the top of declarative list Decls.
+ -- Return the entity of the anonymous master.
- begin
- Unit_Id := Cunit_Entity (Current_Sem_Unit);
+ -----------------------------
+ -- Create_Anonymous_Master --
+ -----------------------------
- -- Find the entity of the current unit
+ function Create_Anonymous_Master
+ (Unit_Id : Entity_Id;
+ Decls : List_Id) return Entity_Id
+ is
+ First_Decl : Node_Id := Empty;
+ -- The first declaration of list Decls. This variable is used when
+ -- inserting various actions.
- if Ekind (Unit_Id) = E_Subprogram_Body then
+ procedure Insert_And_Analyze (Action : Node_Id);
+ -- Insert arbitrary node Action in declarative list Decl and analyze
+ -- it.
- -- When processing subprogram bodies, the proper scope is always that
- -- of the spec.
+ ------------------------
+ -- Insert_And_Analyze --
+ ------------------------
- Subp_Body := Unit_Id;
- while Present (Subp_Body)
- and then Nkind (Subp_Body) /= N_Subprogram_Body
- loop
- Subp_Body := Parent (Subp_Body);
- end loop;
+ procedure Insert_And_Analyze (Action : Node_Id) is
+ begin
+ -- The list is already populated, the actions are inserted at the
+ -- top of the list, preserving their order.
- Unit_Id := Corresponding_Spec (Subp_Body);
- end if;
+ if Present (First_Decl) then
+ Insert_Before_And_Analyze (First_Decl, Action);
- Loc := Sloc (Unit_Id);
- Unit_Decl := Unit (Cunit (Current_Sem_Unit));
+ -- Otherwise append to the declarations to preserve order
- -- Find the declarations list of the current unit
+ else
+ Append_To (Decls, Action);
+ Analyze (Action);
+ end if;
+ end Insert_And_Analyze;
- if Nkind (Unit_Decl) = N_Package_Declaration then
- Unit_Decl := Specification (Unit_Decl);
- Decls := Visible_Declarations (Unit_Decl);
+ -- Local variables
- if No (Decls) then
- Decls := New_List (Make_Null_Statement (Loc));
- Set_Visible_Declarations (Unit_Decl, Decls);
+ Loc : constant Source_Ptr := Sloc (Unit_Id);
+ FM_Id : Entity_Id;
- elsif Is_Empty_List (Decls) then
- Append_To (Decls, Make_Null_Statement (Loc));
- end if;
+ -- Start of processing for Create_Anonymous_Master
- else
- Decls := Declarations (Unit_Decl);
-
- if No (Decls) then
- Decls := New_List (Make_Null_Statement (Loc));
- Set_Declarations (Unit_Decl, Decls);
-
- elsif Is_Empty_List (Decls) then
- Append_To (Decls, Make_Null_Statement (Loc));
+ begin
+ if Present (Decls) then
+ First_Decl := First (Decls);
end if;
- end if;
- -- The current unit has an existing anonymous master, traverse its
- -- declarations and locate the entity.
+ -- Since the anonymous master and all its initialization actions are
+ -- inserted at top level, use the scope of the unit when analyzing.
- if Has_Anonymous_Master (Unit_Id) then
- declare
- Decl : Node_Id;
- Fin_Mas_Id : Entity_Id;
+ Push_Scope (Unit_Id);
- begin
- Decl := First (Decls);
- while Present (Decl) loop
+ -- Create the anonymous master
- -- Look for the first variable in the declarations whole type
- -- is Finalization_Master.
+ FM_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Unit_Id), "AM"));
+ Set_Anonymous_Master (Unit_Id, FM_Id);
- if Nkind (Decl) = N_Object_Declaration then
- Fin_Mas_Id := Defining_Identifier (Decl);
+ -- Generate:
+ -- <FM_Id> : Finalization_Master;
- if Ekind (Fin_Mas_Id) = E_Variable
- and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
- then
- return Fin_Mas_Id;
- end if;
- end if;
+ Insert_And_Analyze
+ (Make_Object_Declaration (Loc,
+ Defining_Identifier => FM_Id,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
- Next (Decl);
- end loop;
+ -- Do not set the base pool and mode of operation on .NET/JVM since
+ -- those targets do not support pools and all VM masters defaulted to
+ -- heterogeneous.
- -- The master was not found even though the unit was labeled as
- -- having one.
+ if VM_Target = No_VM then
- raise Program_Error;
- end;
+ -- Generate:
+ -- Set_Base_Pool
+ -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
- -- Create a new anonymous master
+ Insert_And_Analyze
+ (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))));
- else
- declare
- First_Decl : constant Node_Id := First (Decls);
- Action : Node_Id;
- Fin_Mas_Id : Entity_Id;
-
- begin
- -- Since the master and its associated initialization is inserted
- -- at top level, use the scope of the unit when analyzing.
-
- Push_Scope (Unit_Id);
-
- -- Create the finalization master
-
- Fin_Mas_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Unit_Id), "AM"));
-
-- Generate:
- -- <Fin_Mas_Id> : Finalization_Master;
+ -- Set_Is_Heterogeneous (<FM_Id>);
- Action :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Fin_Mas_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
+ Insert_And_Analyze
+ (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))));
+ end if;
- Insert_Before_And_Analyze (First_Decl, Action);
+ Pop_Scope;
- -- Mark the unit to prevent the generation of multiple masters
+ return FM_Id;
+ end Create_Anonymous_Master;
- Set_Has_Anonymous_Master (Unit_Id);
+ -- Local declarations
- -- Do not set the base pool and mode of operation on .NET/JVM
- -- since those targets do not support pools and all VM masters
- -- are heterogeneous by default.
+ Unit_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
+ Unit_Id : constant Entity_Id := Corresponding_Spec_Of (Unit_Decl);
+ Decls : List_Id;
+ FM_Id : Entity_Id;
+ Unit_Spec : Node_Id;
- if VM_Target = No_VM then
+ -- Start of processing for Current_Anonymous_Master
- -- Generate:
- -- Set_Base_Pool
- -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
+ begin
+ FM_Id := Anonymous_Master (Unit_Id);
- Action :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
+ -- Create a new anonymous master when allocating an object of anonymous
+ -- access-to-controlled type for the first time.
- Parameter_Associations => New_List (
- New_Occurrence_Of (Fin_Mas_Id, Loc),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
- Attribute_Name => Name_Unrestricted_Access)));
+ if No (FM_Id) then
- Insert_Before_And_Analyze (First_Decl, Action);
+ -- Find the declarative list of the current unit
- -- Generate:
- -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
+ if Nkind (Unit_Decl) = N_Package_Declaration then
+ Unit_Spec := Specification (Unit_Decl);
+ Decls := Visible_Declarations (Unit_Spec);
- Action :=
- 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)));
-
- Insert_Before_And_Analyze (First_Decl, Action);
+ if No (Decls) then
+ Decls := New_List;
+ Set_Visible_Declarations (Unit_Spec, Decls);
end if;
- -- Restore the original state of the scope stack
+ -- Package or subprogram body
- Pop_Scope;
+ else
+ Decls := Declarations (Unit_Decl);
- return Fin_Mas_Id;
- end;
+ if No (Decls) then
+ Decls := New_List;
+ Set_Declarations (Unit_Decl, Decls);
+ end if;
+ end if;
+
+ FM_Id := Create_Anonymous_Master (Unit_Id, Decls);
end if;
+
+ return FM_Id;
end Current_Anonymous_Master;
--------------------------------
This patch reimplements the generation of anonymous finalization masters used in servicing anonymous access-to-controlled type allocations. The modification prevents the generation of a duplicate anonymous master in certain cases. ------------ -- Source -- ------------ -- gen_pack.ads with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; generic package Gen_Pack is type Rec is tagged record Comp : Unbounded_String; end record; procedure Force_Body; end Gen_Pack; -- gen_pack.adb package body Gen_Pack is Ptr : access Rec := new Rec; procedure Force_Body is begin null; end Force_Body; end Gen_Pack; -- pack.ads with Gen_Pack; package Pack is procedure Force_Body; package Inst_1 is new Gen_Pack; end Pack; -- pack.adb package body Pack is procedure Force_Body is begin null; end Force_Body; package Inst_2 is new Gen_Pack; end Pack; ----------------- -- Compilation -- ----------------- $ gcc -c pack.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2015-05-22 Hristian Kirtchev <kirtchev@adacore.com> * einfo.adb Node36 is now used as Anonymous_Master. Flag253 is now unused. (Anonymous_Master): New routine. (Has_Anonymous_Master): Removed. (Set_Anonymous_Master): New routine. (Set_Has_Anonymous_Master): Removed. (Write_Entity_Flags): Remove the output for Has_Anonymous_Maser. (Write_Field36_Name): Add output for Anonymous_Master. * einfo.ads Add new attribute Anonymous_Master along with occurrences in nodes. Remove attribute Has_Anonymous_Master along with occurrences in nodes. (Anonymous_Master): New routine along with pragma Inline. (Has_Anonymous_Master): Removed along with pragma Inline. (Set_Anonymous_Master): New routine along with pragma Inline. (Set_Has_Anonymous_Master): Removed along with pragma Inline. * exp_ch4.adb (Create_Anonymous_Master): New routine. (Current_Anonymous_Master): Reimplemented.