From: Eric Botcazou <ebotca...@adacore.com>
The coupling came from the build-in-place protocol but is now unnecessary
because the storage pool reference is always passed along with the master
reference in this protocol. No functional changes.
gcc/ada/
* exp_ch3.adb (Build_Heap_Or_Pool_Allocator): Use the BIPstoragepool
formal parameter to retrieve the pool in the presence of a master.
* exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Always pass
a pool reference along with the master reference.
(Make_Build_In_Place_Call_In_Object_Declaration): Likewise.
* exp_ch7.adb (Build_BIP_Cleanup_Stmts): Use the BIPstoragepool
formal parameter to retrieve the pool in the presence of a master.
(Create_Anonymous_Master): Do not call Set_Base_Pool.
(Build_Finalization_Master): Likewise.
* rtsfind.ads (RE_Id): Remove RE_Base_Pool and RE_Set_Base_Pool.
(RE_Unit_Table): Remove associated entries.
* libgnat/s-finmas.ads: Remove clause for System.Storage_Pools.
(Any_Storage_Pool_Ptr): Delete.
(Finalization_Master): Remove Base_Pool component.
(Base_Pool): Delete.
(Set_Base_Pool): Likewise.
* libgnat/s-finmas.adb (Base_Pool): Likewise.
(Set_Base_Pool): Likewise.
(Print_Master): Do not print Base_Pool.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch3.adb | 49 +++++++++++-----------
gcc/ada/exp_ch6.adb | 33 ++++++++++++---
gcc/ada/exp_ch7.adb | 79 ++++++++++++------------------------
gcc/ada/libgnat/s-finmas.adb | 30 --------------
gcc/ada/libgnat/s-finmas.ads | 22 ----------
gcc/ada/rtsfind.ads | 4 --
6 files changed, 76 insertions(+), 141 deletions(-)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 4ebc7b977e9..f8d41b1bfc0 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6254,8 +6254,7 @@ package body Exp_Ch3 is
-- else
-- declare
-- type Ptr_Typ is access Ret_Typ;
- -- for Ptr_Typ'Storage_Pool use
- -- Base_Pool (BIPfinalizationmaster.all).all;
+ -- for Ptr_Typ'Storage_Pool use BIPstoragepool.all;
-- Local : Ptr_Typ;
--
-- begin
@@ -6497,25 +6496,27 @@ package body Exp_Ch3 is
begin
-- Generate:
- -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
-
- Pool_Id := Make_Temporary (Loc, 'P');
-
- Append_To (Decls,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Pool_Id,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
- Parameter_Associations => New_List (
- Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
+ -- Pool_Id renames BIPstoragepool.all;
+
+ -- This formal is not added on ZFP as those targets do not
+ -- support pools.
+
+ if RTE_Available (RE_Root_Storage_Pool_Ptr) then
+ Pool_Id := Make_Temporary (Loc, 'P');
+
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pool_Id,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of
+ (Build_In_Place_Formal
+ (Func_Id, BIP_Storage_Pool), Loc))));
+ else
+ Pool_Id := Empty;
+ end if;
-- Create an access type which uses the storage pool of the
-- caller's master. This additional type is necessary because
@@ -6572,10 +6573,8 @@ package body Exp_Ch3 is
Unchecked_Convert_To (Temp_Typ,
New_Occurrence_Of (Local_Id, Loc))));
- -- Wrap the allocation in a block. This is further conditioned
- -- by checking the caller finalization master at runtime. A
- -- null value indicates a non-existent master, most likely due
- -- to a Finalize_Storage_Only allocation.
+ -- Wrap the allocation in a block to make it conditioned by the
+ -- presence of the caller's finalization master at run time.
-- Generate:
-- if BIPfinalizationmaster = null then
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 0ab6c0080bf..928307a233d 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -8372,7 +8372,16 @@ package body Exp_Ch6 is
Attribute_Name => Name_Unrestricted_Access);
-- No user-defined pool; pass an allocation parameter indicating that
- -- the function should allocate its result on the heap.
+ -- the function should allocate its result on the heap. When there is
+ -- a finalization master, a pool reference is required.
+
+ elsif Needs_BIP_Finalization_Master (Function_Id) then
+ Alloc_Form := Global_Heap;
+ Pool_Actual :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
+ Attribute_Name => Name_Unrestricted_Access);
else
Alloc_Form := Global_Heap;
@@ -9062,15 +9071,11 @@ package body Exp_Ch6 is
elsif Is_Library_Level_Entity (Obj_Def_Id)
and then not Restriction_Active (No_Implicit_Heap_Allocations)
then
- Add_Unconstrained_Actuals_To_Build_In_Place_Call
- (Func_Call, Function_Id, Alloc_Form => Global_Heap);
- Caller_Object := Empty;
-
-- Create a finalization master for the access result type to ensure
-- that the heap allocation can properly chain the object and later
-- finalize it when the library unit goes out of scope.
- if Needs_Finalization (Etype (Func_Call)) then
+ if Needs_BIP_Finalization_Master (Func_Call) then
Build_Finalization_Master
(Typ => Ptr_Typ,
For_Lib_Level => True,
@@ -9081,8 +9086,24 @@ package body Exp_Ch6 is
Prefix =>
New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
Attribute_Name => Name_Unrestricted_Access);
+
+ Pool_Actual :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+
+ else
+ Pool_Actual := Empty;
end if;
+ Add_Unconstrained_Actuals_To_Build_In_Place_Call
+ (Func_Call,
+ Function_Id,
+ Alloc_Form => Global_Heap,
+ Pool_Exp => Pool_Actual);
+ Caller_Object := Empty;
+
-- In other indefinite cases, pass an indication to do the allocation
-- on the secondary stack and set Caller_Object to Empty so that a null
-- value will be passed for the caller's object address. A transient
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 693d9b1c5a7..f4a0a85ff1c 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -595,8 +595,7 @@ package body Exp_Ch7 is
-- then
-- declare
-- type Ptr_Typ is access Fun_Typ;
- -- for Ptr_Typ'Storage_Pool use
- -- Base_Pool (BIPfinalizationmaster.all).all;
+ -- for Ptr_Typ'Storage_Pool use BIPstoragepool.all;
--
-- begin
-- Free (Ptr_Typ (Obj_Addr));
@@ -628,25 +627,32 @@ package body Exp_Ch7 is
begin
-- Generate:
- -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
+ -- Pool_Id renames BIPstoragepool.all;
- Pool_Id := Make_Temporary (Loc, 'P');
+ -- This formal is not added on ZFP as those targets do not
+ -- support pools.
- Append_To (Decls,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Pool_Id,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
- Parameter_Associations => New_List (
- Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
+ if RTE_Available (RE_Root_Storage_Pool_Ptr) then
+ Pool_Id := Make_Temporary (Loc, 'P');
+
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pool_Id,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of
+ (Build_In_Place_Formal
+ (Func_Id, BIP_Storage_Pool), Loc))));
+
+ if Debug_Generated_Code then
+ Set_Debug_Info_Needed (Pool_Id);
+ end if;
+
+ else
+ Pool_Id := Empty;
+ end if;
-- Create an access type which uses the storage pool of the
-- caller's finalization master.
@@ -670,10 +676,6 @@ package body Exp_Ch7 is
Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
- if Debug_Generated_Code then
- Set_Debug_Info_Needed (Pool_Id);
- end if;
-
-- Create an explicit free statement. Note that the free uses the
-- caller's pool expressed as a renaming.
@@ -1008,7 +1010,6 @@ package body Exp_Ch7 is
Decls : List_Id;
FM_Decl : Node_Id;
FM_Id : Entity_Id;
- FM_Init : Node_Id;
Unit_Spec : Node_Id;
begin
@@ -1023,21 +1024,6 @@ package body Exp_Ch7 is
Object_Definition =>
New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
- -- Generate:
- -- Set_Base_Pool
- -- (<FM_Id>, 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
@@ -1069,7 +1055,6 @@ package body Exp_Ch7 is
end if;
end if;
- Prepend_To (Decls, FM_Init);
Prepend_To (Decls, FM_Decl);
-- Use the scope of the unit when analyzing the declaration of the
@@ -1077,7 +1062,6 @@ package body Exp_Ch7 is
Push_Scope (Unit_Id);
Analyze (FM_Decl);
- Analyze (FM_Init);
Pop_Scope;
-- Mark the master as servicing this specific designated type
@@ -1621,19 +1605,6 @@ package body Exp_Ch7 is
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
end if;
- -- Generate:
- -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
-
- Append_To (Actions,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Fin_Mas_Id, Loc),
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Pool_Id, Loc),
- Attribute_Name => Name_Unrestricted_Access))));
-
-- A finalization master created for an access designating a type
-- with private components is inserted before a context-dependent
-- node.
diff --git a/gcc/ada/libgnat/s-finmas.adb b/gcc/ada/libgnat/s-finmas.adb
index edf0242e954..f0e081662f5 100644
--- a/gcc/ada/libgnat/s-finmas.adb
+++ b/gcc/ada/libgnat/s-finmas.adb
@@ -68,17 +68,6 @@ package body System.Finalization_Masters is
L.Next := N;
end Attach_Unprotected;
- ---------------
- -- Base_Pool --
- ---------------
-
- function Base_Pool
- (Master : Finalization_Master) return Any_Storage_Pool_Ptr
- is
- begin
- return Master.Base_Pool;
- end Base_Pool;
-
------------------------
-- Detach_Unprotected --
------------------------
@@ -240,13 +229,6 @@ package body System.Finalization_Masters is
Put ("Master : ");
Put_Line (Address_Image (Master'Address));
- Put ("Base_Pool: ");
- if Master.Base_Pool = null then
- Put_Line ("null");
- else
- Put_Line (Address_Image (Master.Base_Pool'Address));
- end if;
-
Put ("Fin_Start: ");
Put_Line (Master.Finalization_Started'Img);
@@ -341,16 +323,4 @@ package body System.Finalization_Masters is
end loop;
end Print_Master;
- -------------------
- -- Set_Base_Pool --
- -------------------
-
- procedure Set_Base_Pool
- (Master : in out Finalization_Master;
- Pool_Ptr : Any_Storage_Pool_Ptr)
- is
- begin
- Master.Base_Pool := Pool_Ptr;
- end Set_Base_Pool;
-
end System.Finalization_Masters;
diff --git a/gcc/ada/libgnat/s-finmas.ads b/gcc/ada/libgnat/s-finmas.ads
index d1edda9de66..85180496352 100644
--- a/gcc/ada/libgnat/s-finmas.ads
+++ b/gcc/ada/libgnat/s-finmas.ads
@@ -31,7 +31,6 @@
with Ada.Finalization;
with System.Storage_Elements;
-with System.Storage_Pools;
package System.Finalization_Masters is
pragma Preelaborate;
@@ -50,13 +49,6 @@ package System.Finalization_Masters is
type FM_Node_Ptr is access all FM_Node;
pragma No_Strict_Aliasing (FM_Node_Ptr);
- -- A reference to any derivation from Root_Storage_Pool. Since this type
- -- may not be used to allocate objects, its storage size is zero.
-
- type Any_Storage_Pool_Ptr is
- access System.Storage_Pools.Root_Storage_Pool'Class;
- for Any_Storage_Pool_Ptr'Storage_Size use 0;
-
-- Finalization master type structure. A unique master is associated with
-- each access-to-controlled or access-to-class-wide type. Masters also act
-- as components of subpools. By default, a master contains objects of the
@@ -115,10 +107,6 @@ private
type Finalization_Master is
new Ada.Finalization.Limited_Controlled with
record
- Base_Pool : Any_Storage_Pool_Ptr := null;
- -- A reference to the pool which this finalization master services. This
- -- field is used in conjunction with the build-in-place machinery.
-
Objects : aliased FM_Node;
-- A doubly linked list which contains the headers of all controlled
-- objects allocated in a [sub]pool.
@@ -136,17 +124,7 @@ private
(Addr : System.Address;
Offset : System.Storage_Elements.Storage_Offset) return System.Address;
- function Base_Pool
- (Master : Finalization_Master) return Any_Storage_Pool_Ptr;
- -- Return a reference to the underlying storage pool on which the master
- -- operates.
-
overriding procedure Initialize (Master : in out Finalization_Master);
-- Initialize the dummy head of a finalization master
- procedure Set_Base_Pool
- (Master : in out Finalization_Master;
- Pool_Ptr : Any_Storage_Pool_Ptr);
- -- Set the underlying pool of a finalization master
-
end System.Finalization_Masters;
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 0b88409795a..82614827e89 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -919,10 +919,8 @@ package Rtsfind is
RE_Attr_Long_Long_Float, -- System.Fat_LLF
RE_Add_Offset_To_Address, -- System.Finalization_Masters
- RE_Base_Pool, -- System.Finalization_Masters
RE_Finalization_Master, -- System.Finalization_Masters
RE_Finalization_Master_Ptr, -- System.Finalization_Masters
- RE_Set_Base_Pool, -- System.Finalization_Masters
RE_Attach_Object_To_Master, -- System.Finalization_Primitives
RE_Attach_Object_To_Node, -- System.Finalization_Primitives
@@ -2571,10 +2569,8 @@ package Rtsfind is
RE_Attr_Long_Long_Float => System_Fat_LLF,
RE_Add_Offset_To_Address => System_Finalization_Masters,
- RE_Base_Pool => System_Finalization_Masters,
RE_Finalization_Master => System_Finalization_Masters,
RE_Finalization_Master_Ptr => System_Finalization_Masters,
- RE_Set_Base_Pool => System_Finalization_Masters,
RE_Attach_Object_To_Master => System_Finalization_Primitives,
RE_Attach_Object_To_Node => System_Finalization_Primitives,
--
2.43.2
