[Ada] Temporary tweak new expansion of contracts

In the case of a function, the new expansion of contracts makes use of an
extended return statement to store the result of the function in the return
object while the post-conditions are evaluated.

Unfortunately GNAT does not elide the copy of the return object for extended
return statements for the time being, so this scheme incurs an extra copy of
the return value on the primary or secondary stack, as well as an additional
pair of calls to Adjust/Finalize when the return type needs finalization.

This temporarily changes the expansion to use a block statement containing a
renaming, which does not incur the extra copy provided that it is manually
adjusted to be recognized by the existing "tail call" optimization present
in the Expand_Simple_Function_Return routine.

gcc/ada/

	* contracts.adb (uild_Subprogram_Contract_Wrapper): Remove useless
	local variable. In the case of a function, replace the extended
	return statement by a block statement declaring a renaming of the
	call to the local subprogram after removing side effects manually.
	(Expand_Subprogram_Contract): Adjust description accordingly.
	* exp_ch6.adb (Expand_Ctrl_Function_Call): Rewrite obsolete
	comment and do not apply the transformation twice.
	* sem_attr.adb (Analyze_Attribute_Old_Result): Now expect a block
	statement instead of an extended return statement.

1 files changed, 84 insertions, 35 deletions

diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 46c9511..34db67a 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -1577,7 +1577,6 @@ package body Contracts is
       Decls   : List_Id;
       Result  : Entity_Id)
    is
-      Actuals   : constant List_Id    := Empty_List;
       Body_Decl : constant Entity_Id  := Unit_Declaration_Node (Body_Id);
       Loc       : constant Source_Ptr := Sloc (Body_Decl);
       Spec_Id   : constant Entity_Id  := Corresponding_Spec (Body_Decl);
@@ -1606,11 +1605,11 @@ package body Contracts is
       Ret_Type := Etype (Subp_Id);
 
       --  Generate the contracts wrapper by moving the original declarations
-      --  and statements within a local subprogram and calling it within
-      --  an extended return to preserve the result for the purpose of
-      --  evaluating postconditions, contracts, type invariants, etc.
+      --  and statements within a local subprogram, calling it and possibly
+      --  preserving the result for the purpose of evaluating postconditions,
+      --  contracts, type invariants, etc.
 
-      --  Generate:
+      --  In the case of a function, generate:
       --
       --  function Original_Func (X : in out Integer) return Typ is
       --     <prologue renamings>
@@ -1623,13 +1622,25 @@ package body Contracts is
       --     end;
       --
       --  begin
-      --     return
-      --        Result_Obj : constant Typ := _Wrapped_Statements
-      --     do
+      --     declare
+      --        type Axx is access all Typ;
+      --        Rxx : constant Axx := _Wrapped_Statements'reference;
+      --        Result_Obj : Typ renames Rxx.all;
+      --
+      --     begin
       --        <postconditions statments>
-      --     end return;
+      --        return Rxx.all;
+      --     end;
       --  end;
       --
+      --  This sequence is recognized by Expand_Simple_Function_Return as a
+      --  tail call, in other words equivalent to "return _Wrapped_Statements;"
+      --  and thus the copy to the anonymous return object is elided, including
+      --  a pair of calls to Adjust/Finalize for types requiring finalization.
+
+      --  Note that an extended return statement does not yield the same result
+      --  because the copy of the return object is not elided by GNAT for now.
+
       --  Or, in the case of a procedure:
       --
       --  procedure Original_Proc (X : in out Integer) is
@@ -1680,8 +1691,7 @@ package body Contracts is
       Set_Declarations (Body_Decl, Decls);
       Set_Handled_Statement_Sequence (Body_Decl,
         Make_Handled_Sequence_Of_Statements (Loc,
-          End_Label  => Make_Identifier (Loc, Chars (Wrapper_Id)),
-          Statements => New_List));
+          End_Label  => Make_Identifier (Loc, Chars (Wrapper_Id))));
 
       --  Move certain flags which are relevant to the body
 
@@ -1697,7 +1707,7 @@ package body Contracts is
       Set_Has_Pragma_Inline_Always
         (Wrapper_Id, Has_Pragma_Inline_Always (Subp_Id));
 
-      --  Generate call to the wrapper
+      --  Prepend a call to the wrapper when the subprogram is a procedure
 
       if No (Ret_Type) or else Ret_Type = Standard_Void_Type then
          Prepend_To (Stmts,
@@ -1706,25 +1716,64 @@ package body Contracts is
          Set_Statements
            (Handled_Statement_Sequence (Body_Decl), Stmts);
 
-      --  Generate the post-execution statements and the extended return
-      --  when the subprogram being wrapped is a function.
+      --  Declare a renaming of the result of the call to the wrapper and
+      --  append a return of the result of the call when the subprogram is
+      --  a function, after manually removing the side effects. Note that
+      --  we cannot call Remove_Side_Effects here because nothing has been
+      --  analyzed yet and we cannot return the renaming itself because
+      --  Expand_Simple_Function_Return expects an explicit dereference.
 
       else
-         Set_Statements (Handled_Statement_Sequence (Body_Decl), New_List (
-           Make_Extended_Return_Statement (Loc,
-             Return_Object_Declarations => New_List (
-                Make_Object_Declaration (Loc,
-                  Defining_Identifier => Result,
-                  Object_Definition   =>
-                    New_Occurrence_Of (Ret_Type, Loc),
-                  Expression          =>
-                    Make_Function_Call (Loc,
-                      Name                   =>
-                        New_Occurrence_Of (Wrapper_Id, Loc),
-                      Parameter_Associations => Actuals))),
-             Handled_Statement_Sequence =>
-               Make_Handled_Sequence_Of_Statements (Loc,
-                 Statements => Stmts))));
+         declare
+            A_Id : constant Node_Id := Make_Temporary (Loc, 'A');
+            R_Id : constant Node_Id := Make_Temporary (Loc, 'R');
+
+         begin
+            Set_Statements (Handled_Statement_Sequence (Body_Decl), New_List (
+              Make_Block_Statement (Loc,
+
+                Declarations => New_List (
+                  Make_Full_Type_Declaration (Loc,
+                    Defining_Identifier => A_Id,
+                    Type_Definition     =>
+                      Make_Access_To_Object_Definition (Loc,
+                        All_Present        => True,
+                        Null_Exclusion_Present => True,
+                        Subtype_Indication =>
+                          New_Occurrence_Of (Ret_Type, Loc))),
+
+                  Make_Object_Declaration (Loc,
+                    Defining_Identifier => R_Id,
+                    Object_Definition   => New_Occurrence_Of (A_Id, Loc),
+                    Constant_Present    => True,
+                    Expression          =>
+                      Make_Reference (Loc,
+                        Make_Function_Call (Loc,
+                          Name => New_Occurrence_Of (Wrapper_Id, Loc)))),
+
+                  Make_Object_Renaming_Declaration (Loc,
+                    Defining_Identifier => Result,
+                    Subtype_Mark        => New_Occurrence_Of (Ret_Type, Loc),
+                    Name                =>
+                      Make_Explicit_Dereference (Loc,
+                        New_Occurrence_Of (R_Id, Loc)))),
+
+                Handled_Statement_Sequence =>
+                  Make_Handled_Sequence_Of_Statements (Loc,
+                    Statements => Stmts))));
+
+            Append_To (Stmts,
+              Make_Simple_Return_Statement (Loc,
+                Expression =>
+                  Make_Explicit_Dereference (Loc,
+                    New_Occurrence_Of (R_Id, Loc))));
+
+            --  It is required for Is_Related_To_Func_Return to return True
+            --  that the temporary Rxx be related to the expression of the
+            --  simple return statement built just above.
+
+            Set_Related_Expression (R_Id, Expression (Last (Stmts)));
+         end;
       end if;
    end Build_Subprogram_Contract_Wrapper;
 
@@ -3387,16 +3436,16 @@ package body Contracts is
       --       <preconditions from body>
       --       <contract case conditions>
 
-      --       function _wrapped_statements (...) return ... is
+      --       function _Wrapped_Statements (...) return ... is
       --          <source declarations>
       --       begin
       --          <source statements>
-      --       end _wrapped_statements;
+      --       end _Wrapped_Statements;
 
       --    begin
-      --       return
-      --          Result : ... := _wrapped_statements
-      --       do
+      --       declare
+      --          Result : ... renames _Wrapped_Statements;
+      --       begin
       --          <refined postconditions from body>
       --          <postconditions from body>
       --          <postconditions from spec>
@@ -3405,7 +3454,7 @@ package body Contracts is
       --          <invariant check of function result>
       --          <invariant and predicate checks of parameters
       --          return Result;
-      --       end return;
+      --       end;
       --    end Original_Code;
 
       --  Step 1: augment contracts list with postconditions associated with