* [Ada] Temporary tweak new expansion of contracts
@ 2022-09-12 8:19 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2022-09-12 8:19 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
[-- Attachment #1: Type: text/plain, Size: 1402 bytes --]
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.
Tested on x86_64-pc-linux-gnu, committed on trunk
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.
[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 9638 bytes --]
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
--- 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
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -5052,11 +5052,11 @@ package body Exp_Ch6 is
Set_Analyzed (N);
- -- A function which returns a controlled object uses the secondary
- -- stack. Rewrite the call into a temporary which obtains the result of
- -- the function using 'reference.
+ -- Apply the transformation, unless it was already applied manually
- Remove_Side_Effects (N);
+ if Nkind (Par) /= N_Reference then
+ Remove_Side_Effects (N);
+ end if;
-- The side effect removal of the function call produced a temporary.
-- When the context is a case expression, if expression, or expression
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1454,10 +1454,10 @@ package body Sem_Attr is
Subp_Decl := Find_Related_Declaration_Or_Body (Prag);
end if;
- -- 'Old objects appear in extended return statements as part of
- -- the expansion of contract wrappers.
+ -- 'Old objects appear in block statements as part of the expansion
+ -- of contract wrappers.
- if Nkind (Subp_Decl) = N_Extended_Return_Statement then
+ if Nkind (Subp_Decl) = N_Block_Statement then
Subp_Decl := Parent (Parent (Subp_Decl));
end if;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-09-12 8:19 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-09-12 8:19 [Ada] Temporary tweak new expansion of contracts Marc Poulhiès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).