ada: Partial implementation of redesign of support for object finalization

This set of changes is a partial reimplemention of the support for Ada
finalization in the GNAT compiler and run-time library, based on the
redesign done by Hristian Kirtchev in February 2022.  It only affects
the scope-based finalization of objects and does not touch the support
for finalization of dynamically allocated objects.

It also does not modify the internal architecture of this support in the
front-end but only changes its output, i.e. the expanded code.  In other
words, the code-based dispatching scheme in finalizers and the hook-based
approach for transient objects are replaced by finalization scope masters
and master nodes, which maintain a list of objects needing finalization,
but the expansion of the code that builds these masters is still performed
mainly during a dedicated post-processing phase.

gcc/ada/

	* Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-finpri$(objext).
	* contracts.adb (Add_Call_Helper): Append freeze actions to the
	class-wide type rather than the specific tagged type.
	* einfo.ads (Finalization_Master_Node_Or_Node): Document.
	(Status_Flag_Or_Transient_Decl): Remove.
	* exp_attr.adb (Expand_N_Attribute_Reference) <Address>: Do not
	adjust a return object of a class-wide interface type.
	* exp_ch3.adb  (Expand_Freeze_Class_Wide_Type): Add test that
	Finalize_Address is not already present as a condition for calling
	Make_Finalize_Address_Body.
	(Expand_Freeze_Record_Type): Call Make_Finalize_Address_Body for
	class-wide types of both regular tagged types and interface types.
	* exp_ch4.adb (Process_Transients_In_Expression): Replace the use
	of hooks with the use of master nodes.
	* exp_ch6.adb (Build_Flag_For_Function): Delete.
	(Expand_N_Extended_Return_Statement): Create a master node for the
	return object if it does not exist.  At the end of the statement,
	generate a call to Suppress_Object_Finalize.
	(Expand_Non_Function_Return): Likewise just before the return.
	* exp_ch7.ads (Make_Master_Node_Declaration): Declare.
	(Make_Suppress_Object_Finalize_Call): Likewise.
	* exp_ch7.adb (Build_Finalization_Master): Defer generating the
	call to Set_Finalize_Address until freezing if the Finalize_Address
	procedure has not been analyzed yet.
	(Build_Finalizer): Reimplement the expansion using a finalization
	scope master per finalizer.
	(Insert_Actions_In_Scope_Around): Replace finalization hooks by
	master nodes and calls to the Finalize_Object.
	(Make_Master_Node_Declaration): New procedure.
	(Make_Suppress_Object_Finalize_Call): Likewise.
	* exp_util.ads (Build_Transient_Object_Statements): Delete.
	* exp_util.adb (Build_Transient_Object_Statements): Likewise.
	(Requires_Cleanup_Actions): Remove obsolete code and return true
	for master nodes.
	* gen_il-fields.ads (Opt_Field_Enum): Add
	Finalization_Master_Node_Or_Object and
	remove Status_Flag_Or_Transient_Decl.
	* gen_il-gen-gen_entities.adb (Allocatable_Kind): Likewise.
	* rtsfind.ads (RTU_Id): Add System_Finalization_Primitives.
	(RE_Id): Add entities of System_Finalization_Primitives.
	(RE_Unit_Table): Add entries for them.
	* sem_ch3.adb (Analyze_Object_Declaration): For an array whose type
	has an unconstrained first subtype and a controlled component, set
	the Is_Constr_Array_Subt_With_Bounds flag.
	* libgnat/s-finpri.ads: New file.
	* libgnat/s-finpri.adb: Likewise.

1 files changed, 6 insertions, 100 deletions

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index ad56cfd..fcfd1d7 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -194,10 +194,6 @@ package body Exp_Ch6 is
    --  the activation Chain. Note: Master_Actual can be Empty, but only if
    --  there are no tasks.
 
-   function Build_Flag_For_Function (Func_Id : Entity_Id) return Entity_Id;
-   --  Generate code to declare a boolean flag initialized to False in the
-   --  function Func_Id and return the entity for the flag.
-
    function Caller_Known_Size
      (Func_Call   : Node_Id;
       Result_Subt : Entity_Id) return Boolean;
@@ -911,53 +907,6 @@ package body Exp_Ch6 is
       end if;
    end BIP_Suffix_Kind;
 
-   -----------------------------
-   -- Build_Flag_For_Function --
-   -----------------------------
-
-   function Build_Flag_For_Function (Func_Id : Entity_Id) return Entity_Id is
-      Flag_Decl : Node_Id;
-      Flag_Id   : Entity_Id;
-      Func_Bod  : Node_Id;
-      Loc       : Source_Ptr;
-
-   begin
-      --  Recover the function body
-
-      Func_Bod := Unit_Declaration_Node (Func_Id);
-
-      if Nkind (Func_Bod) = N_Subprogram_Declaration then
-         Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod)));
-      end if;
-
-      if Nkind (Func_Bod) = N_Function_Specification then
-         Func_Bod := Parent (Func_Bod); -- one more level for child units
-      end if;
-
-      pragma Assert (Nkind (Func_Bod) = N_Subprogram_Body);
-
-      Loc := Sloc (Func_Bod);
-
-      --  Create a flag to track the function state
-
-      Flag_Id := Make_Temporary (Loc, 'F');
-
-      --  Insert the flag at the beginning of the function declarations,
-      --  generate:
-      --    Fnn : Boolean := False;
-
-      Flag_Decl :=
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Flag_Id,
-            Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
-            Expression        => New_Occurrence_Of (Standard_False, Loc));
-
-      Prepend_To (Declarations (Func_Bod), Flag_Decl);
-      Analyze (Flag_Decl);
-
-      return Flag_Id;
-   end Build_Flag_For_Function;
-
    ---------------------------
    -- Build_In_Place_Formal --
    ---------------------------
@@ -5622,20 +5571,6 @@ package body Exp_Ch6 is
 
       HSS := Handled_Statement_Sequence (N);
 
-      --  If the returned object needs finalization actions, the function must
-      --  perform the appropriate cleanup should it fail to return. The state
-      --  of the function itself is tracked through a flag which is coupled
-      --  with the scope finalizer. There is one flag per each return object
-      --  in case of multiple extended returns. Note that the flag has already
-      --  been created if the extended return contains a nested return.
-
-      if Needs_Finalization (Etype (Ret_Obj_Id))
-        and then No (Status_Flag_Or_Transient_Decl (Ret_Obj_Id))
-      then
-         Set_Status_Flag_Or_Transient_Decl
-           (Ret_Obj_Id, Build_Flag_For_Function (Func_Id));
-      end if;
-
       --  Build a simple_return_statement that returns the return object when
       --  there is a statement sequence, or no expression, or the analysis of
       --  the return object declaration generated extra actions, or the result
@@ -5689,25 +5624,12 @@ package body Exp_Ch6 is
             end if;
          end if;
 
-         --  Update the state of the function right before the object is
-         --  returned.
+         --  If the returned object needs finalization actions, the function
+         --  must perform the appropriate cleanup should it fail to return.
 
          if Needs_Finalization (Etype (Ret_Obj_Id)) then
-            declare
-               Flag_Id : constant Entity_Id :=
-                           Status_Flag_Or_Transient_Decl (Ret_Obj_Id);
-
-            begin
-               pragma Assert (Present (Flag_Id));
-
-               --  Generate:
-               --    Fnn := True;
-
-               Append_To (Stmts,
-                 Make_Assignment_Statement (Loc,
-                   Name       => New_Occurrence_Of (Flag_Id, Loc),
-                   Expression => New_Occurrence_Of (Standard_True, Loc)));
-            end;
+            Append_To
+              (Stmts, Make_Suppress_Object_Finalize_Call (Loc, Ret_Obj_Id));
          end if;
 
          HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts);
@@ -6368,8 +6290,6 @@ package body Exp_Ch6 is
          declare
             Ret_Obj_Id : constant Entity_Id := First_Entity (Scope_Id);
 
-            Flag_Id : Entity_Id;
-
          begin
             --  Apply the same processing as Expand_N_Extended_Return_Statement
             --  if the returned object needs finalization actions. Note that we
@@ -6377,22 +6297,8 @@ package body Exp_Ch6 is
             --  may be multiple nested returns within the extended one.
 
             if Needs_Finalization (Etype (Ret_Obj_Id)) then
-               if Present (Status_Flag_Or_Transient_Decl (Ret_Obj_Id)) then
-                  Flag_Id := Status_Flag_Or_Transient_Decl (Ret_Obj_Id);
-               else
-                  Flag_Id :=
-                    Build_Flag_For_Function (Return_Applies_To (Scope_Id));
-                  Set_Status_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id);
-               end if;
-
-               --  Generate:
-               --    Fnn := True;
-
-               Insert_Action (N,
-                 Make_Assignment_Statement (Loc,
-                   Name       =>
-                     New_Occurrence_Of (Flag_Id, Loc),
-                   Expression => New_Occurrence_Of (Standard_True, Loc)));
+               Insert_Action
+                 (N, Make_Suppress_Object_Finalize_Call (Loc, Ret_Obj_Id));
             end if;
 
             Rewrite (N,