ada: Decouple finalization masters from storage pools

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.
author: Eric Botcazou <ebotcazou@adacore.com> 2024-01-23 08:44:38 +0100
committer: Marc Poulhiès <poulhies@adacore.com> 2024-05-13 10:03:29 +0200
commit: 56e781f6b83ddf26ae42309e682dc22ce4db3f82 (patch)
tree: fc033e85481ea462578519d2dc0754bae7d8f85d /gcc
parent: c1b33f8cf2b40d78d0413a328e3faed384f7e0f4 (diff)
download: gcc-56e781f6b83ddf26ae42309e682dc22ce4db3f82.zip
gcc-56e781f6b83ddf26ae42309e682dc22ce4db3f82.tar.gz
gcc-56e781f6b83ddf26ae42309e682dc22ce4db3f82.tar.bz2
6 files changed, 76 insertions, 141 deletions
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 4ebc7b9..f8d41b1 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 0ab6c00..928307a 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 693d9b1..f4a0a85 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 edf0242..f0e0816 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 d1edda9..8518049 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 0b88409..8261482 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,
author	Eric Botcazou <ebotcazou@adacore.com>	2024-01-23 08:44:38 +0100
committer	Marc Poulhiès <poulhies@adacore.com>	2024-05-13 10:03:29 +0200
commit	56e781f6b83ddf26ae42309e682dc22ce4db3f82 (patch)
tree	fc033e85481ea462578519d2dc0754bae7d8f85d /gcc
parent	c1b33f8cf2b40d78d0413a328e3faed384f7e0f4 (diff)
download	gcc-56e781f6b83ddf26ae42309e682dc22ce4db3f82.zip gcc-56e781f6b83ddf26ae42309e682dc22ce4db3f82.tar.gz gcc-56e781f6b83ddf26ae42309e682dc22ce4db3f82.tar.bz2