From: Eric Botcazou <ebotca...@adacore.com>
...in aggregates. This prevents a temporary from being created on the
primary stack to hold the result of the function calls before it is copied
to the component of the aggregate in the nonlimited by-reference case.
This requires a small tweak to Check_Function_Writable_Actuals to avoid
giving a spurious error in a specific case.
gcc/ada/ChangeLog:
* exp_aggr.ads (Parent_Is_Regular_Aggregate): New predicate.
* exp_aggr.adb (In_Place_Assign_OK.Safe_Component): Implement more
accurate criterion for function calls.
(Convert_To_Assignments): Use Parent_Is_Regular_Aggregate predicate.
(Expand_Array_Aggregate): Likewise. Remove obsolete comment.
(Initialize_Component): Do not adjust when the expression is a naked
function call and Back_End_Return_Slot is True.
(Parent_Is_Regular_Aggregate): New predicate.
* exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): Add test of
Back_End_Return_Slot in conjunction with a function call.
* exp_ch4.adb (Expand_Allocator_Expression): Likewise. Use the
Is_Container_Aggregate predicate to detect container aggregates.
(Expand_N_Case_Expression): Delay the expansion if the parent is a
regular aggregate and the type should not be copied.
(Expand_N_If_Expression): Likewise.
(New_Assign_Copy): New function.
* exp_ch6.adb (Expand_Ctrl_Function_Call): Bail out when the parent
is a regular aggregate.
* sem_util.adb (Check_Function_Writable_Actuals): Do not take into
account attribute references created by the compiler.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 66 ++++++++++++++++++++++----------
gcc/ada/exp_aggr.ads | 4 ++
gcc/ada/exp_ch3.adb | 10 +++--
gcc/ada/exp_ch4.adb | 89 +++++++++++++++++++++++++-------------------
gcc/ada/exp_ch6.adb | 18 +++++++--
gcc/ada/sem_util.adb | 9 +++++
6 files changed, 131 insertions(+), 65 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 8aad7217935..48478f350bb 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -3865,8 +3865,8 @@ package body Exp_Aggr is
function Safe_Component (Expr : Node_Id) return Boolean;
-- Verify that an expression cannot depend on the target being assigned
- -- to. Return true for compile-time known values, stand-alone objects,
- -- parameters passed by copy, calls to functions that return by copy,
+ -- (which is Target_Object if it is set), return true for compile-time
+ -- known values, stand-alone objects, formal parameters passed by copy,
-- selected components thereof only if the aggregate's type is an array,
-- indexed components and slices thereof only if the aggregate's type is
-- a record, and simple expressions involving only these as operands.
@@ -3877,7 +3877,8 @@ package body Exp_Aggr is
-- which is excluded by the above condition. Additionally, if the target
-- is statically known, return true for arbitrarily nested selections,
-- indexations or slicings, provided that their ultimate prefix is not
- -- the target itself.
+ -- the target itself, and calls to functions that take only these as
+ -- actual parameters provided that the target is not aliased.
--------------------
-- Safe_Aggregate --
@@ -3982,12 +3983,26 @@ package body Exp_Aggr is
return Check_Component (Prefix (C), T_OK);
when N_Function_Call =>
- if Nkind (Name (C)) = N_Explicit_Dereference then
- return not Returns_By_Ref (Etype (Name (C)));
- else
- return not Returns_By_Ref (Entity (Name (C)));
+ if No (Target_Object) or else Is_Aliased (Target_Object) then
+ return False;
end if;
+ if Present (Parameter_Associations (C)) then
+ declare
+ Actual : Node_Id;
+ begin
+ Actual := First_Actual (C);
+ while Present (Actual) loop
+ if not Check_Component (Actual, T_OK) then
+ return False;
+ end if;
+ Next_Actual (Actual);
+ end loop;
+ end;
+ end if;
+
+ return True;
+
when N_Indexed_Component | N_Slice =>
-- In a target record, these operations cannot determine
-- alone a component so we can recurse whatever the target.
@@ -4179,11 +4194,7 @@ package body Exp_Aggr is
-- excluding container aggregates as these are transformed into
-- subprogram calls later.
- (Nkind (Parent_Node) = N_Component_Association
- and then not Is_Container_Aggregate (Parent (Parent_Node)))
-
- or else (Nkind (Parent_Node) in N_Aggregate | N_Extension_Aggregate
- and then not Is_Container_Aggregate (Parent_Node))
+ Parent_Is_Regular_Aggregate (Parent_Node)
-- Allocator (see Convert_Aggr_In_Allocator)
@@ -6150,14 +6161,9 @@ package body Exp_Aggr is
if
-- Internal aggregates (transformed when expanding the parent),
-- excluding container aggregates as these are transformed into
- -- subprogram calls later. So far aggregates with self-references
- -- are not supported if they appear in a conditional expression.
+ -- subprogram calls later.
- (Nkind (Parent_Node) = N_Component_Association
- and then not Is_Container_Aggregate (Parent (Parent_Node)))
-
- or else (Nkind (Parent_Node) in N_Aggregate | N_Extension_Aggregate
- and then not Is_Container_Aggregate (Parent_Node))
+ Parent_Is_Regular_Aggregate (Parent_Node)
-- Allocator (see Convert_Aggr_In_Allocator). Sliding cannot be done
-- in place for the time being.
@@ -8703,6 +8709,8 @@ package body Exp_Aggr is
-- generated by Make_Tag_Ctrl_Assignment). But, in the case of an array
-- aggregate, controlled subaggregates are not considered because each
-- of their individual elements will receive an adjustment of its own.
+ -- Moreover, the result of a function call need not be adjusted if it
+ -- has already been adjusted in the called function.
if Finalization_OK
and then not Is_Inherently_Limited_Type (Comp_Typ)
@@ -8711,6 +8719,8 @@ package body Exp_Aggr is
and then Is_Array_Type (Comp_Typ)
and then Needs_Finalization (Component_Type (Comp_Typ))
and then Nkind (Unqualify (Init_Expr)) = N_Aggregate)
+ and then not (Back_End_Return_Slot
+ and then Nkind (Init_Expr) = N_Function_Call)
then
Set_No_Finalize_Actions (Init_Stmt);
@@ -9437,6 +9447,24 @@ package body Exp_Aggr is
return False;
end Must_Slide;
+ ---------------------------------
+ -- Parent_Is_Regular_Aggregate --
+ ---------------------------------
+
+ function Parent_Is_Regular_Aggregate (Par : Node_Id) return Boolean is
+ begin
+ case Nkind (Par) is
+ when N_Component_Association =>
+ return Parent_Is_Regular_Aggregate (Parent (Par));
+
+ when N_Extension_Aggregate | N_Aggregate =>
+ return not Is_Container_Aggregate (Par);
+
+ when others =>
+ return False;
+ end case;
+ end Parent_Is_Regular_Aggregate;
+
---------------------
-- Sort_Case_Table --
---------------------
diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads
index c071e7604ad..0da0d8fe8a8 100644
--- a/gcc/ada/exp_aggr.ads
+++ b/gcc/ada/exp_aggr.ads
@@ -59,6 +59,10 @@ package Exp_Aggr is
-- This is the case if it consists only of iterated component associations
-- with iterator specifications, see RM 4.3.3(20.2/5).
+ function Parent_Is_Regular_Aggregate (Par : Node_Id) return Boolean;
+ -- Return True if Par is an aggregate that is not a container aggregate, or
+ -- a component association of such an aggregate.
+
function Static_Array_Aggregate (N : Node_Id) return Boolean;
-- N is an array aggregate that may have a component association with
-- an others clause and a range. If bounds are static and the expressions
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index cf2238e9ee1..a4e6512410a 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -2675,9 +2675,10 @@ package body Exp_Ch3 is
Exp_Q := Unqualify (Exp);
- -- Adjust the component if controlled, except if it is an aggregate
- -- that will be expanded inline (but note that the case of container
- -- aggregates does require component adjustment), or a function call.
+ -- Adjust the component if controlled, except if the expression is an
+ -- aggregate that will be expanded inline (but note that the case of
+ -- container aggregates does require component adjustment), or else
+ -- a function call whose result is adjusted in the called function.
-- Note that, when we don't inhibit component adjustment, the tag
-- will be automatically inserted by Make_Tag_Ctrl_Assignment in the
-- tagged case. Otherwise, we have to generate a tag assignment here.
@@ -2686,7 +2687,8 @@ package body Exp_Ch3 is
and then (Nkind (Exp_Q) not in N_Aggregate | N_Extension_Aggregate
or else Is_Container_Aggregate (Exp_Q))
and then not Is_Build_In_Place_Function_Call (Exp)
- and then Nkind (Exp) /= N_Function_Call
+ and then not (Back_End_Return_Slot
+ and then Nkind (Exp) = N_Function_Call)
then
Set_No_Finalize_Actions (First (Res));
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 0cf5643ebe4..ce90f33aeda 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -240,6 +240,10 @@ package body Exp_Ch4 is
-- skipped if the operation is done in Bignum mode but that's fine, since
-- the Bignum call takes care of everything.
+ function New_Assign_Copy (N : Node_Id; Expr : Node_Id) return Node_Id;
+ -- N is an assignment statement. Return a copy of N with the same name but
+ -- expression changed to Expr and perform a couple of adjustments.
+
procedure Narrow_Large_Operation (N : Node_Id);
-- Try to compute the result of a large operation in a narrower type than
-- its nominal type. This is mainly aimed at getting rid of operations done
@@ -727,7 +731,7 @@ package body Exp_Ch4 is
-- adjust after the assignment but, in either case, we do not
-- finalize before since the target is newly allocated memory.
- if Nkind (Exp) = N_Function_Call then
+ if Back_End_Return_Slot and then Nkind (Exp) = N_Function_Call then
Set_No_Ctrl_Actions (Assign);
else
Set_No_Finalize_Actions (Assign);
@@ -869,10 +873,7 @@ package body Exp_Ch4 is
-- as qualified expression must be rewritten into the form expected by
-- Expand_Container_Aggregate, resp. Two_Pass_Aggregate_Expansion.
- if Nkind (Exp) = N_Aggregate
- and then (Has_Aspect (T, Aspect_Aggregate)
- or else Is_Two_Pass_Aggregate (Exp))
- then
+ if Is_Container_Aggregate (Exp) or else Is_Two_Pass_Aggregate (Exp) then
Temp := Make_Temporary (Loc, 'P', N);
Set_Analyzed (Exp, False);
Insert_Action (N,
@@ -5191,6 +5192,8 @@ package body Exp_Ch4 is
-- expansion until the (immediate) parent is rewritten as a return
-- statement (or is already the return statement). Likewise if it is
-- in the context of an object declaration that can be optimized.
+ -- Likewise if it is in the context of a regular agggregate and the
+ -- type should not be copied.
if not Expansion_Delayed (N) then
declare
@@ -5198,6 +5201,8 @@ package body Exp_Ch4 is
begin
if Nkind (Uncond_Par) = N_Simple_Return_Statement
or else Is_Optimizable_Declaration (Uncond_Par)
+ or else (Parent_Is_Regular_Aggregate (Uncond_Par)
+ and then not Is_Copy_Type (Typ))
then
Delay_Conditional_Expressions_Between (N, Uncond_Par);
end if;
@@ -5377,17 +5382,7 @@ package body Exp_Ch4 is
if Optimize_Assignment_Stmt then
-- We directly copy the parent node to preserve its flags
- Stmts := New_List (New_Copy (Par));
- Set_Sloc (First (Stmts), Alt_Loc);
- Set_Name (First (Stmts), New_Copy_Tree (Name (Par)));
- Set_Expression (First (Stmts), Alt_Expr);
-
- -- If the expression is itself a conditional expression whose
- -- expansion has been delayed, analyze it again and expand it.
-
- if Is_Delayed_Conditional_Expression (Alt_Expr) then
- Unanalyze_Delayed_Conditional_Expression (Alt_Expr);
- end if;
+ Stmts := New_List (New_Assign_Copy (Par, Alt_Expr));
-- Generate:
-- return AX;
@@ -5805,8 +5800,9 @@ package body Exp_Ch4 is
-- expansion until the (immediate) parent is rewritten as a return
-- statement (or is already the return statement). Likewise if it is
-- in the context of an object declaration that can be optimized.
- -- Note that this deals with the case of the elsif part of the if
- -- expression, if it exists.
+ -- Likewise if it is in the context of a regular agggregate and the
+ -- type should not be copied. Note that this deals with the case of
+ -- the elsif part of the if expression, if it exists.
if not Expansion_Delayed (N) then
declare
@@ -5814,6 +5810,8 @@ package body Exp_Ch4 is
begin
if Nkind (Uncond_Par) = N_Simple_Return_Statement
or else Is_Optimizable_Declaration (Uncond_Par)
+ or else (Parent_Is_Regular_Aggregate (Uncond_Par)
+ and then not Is_Copy_Type (Typ))
then
Delay_Conditional_Expressions_Between (N, Uncond_Par);
end if;
@@ -5916,26 +5914,8 @@ package body Exp_Ch4 is
-- We directly copy the parent node to preserve its flags
- New_Then := New_Copy (Par);
- Set_Sloc (New_Then, Sloc (Thenx));
- Set_Name (New_Then, New_Copy_Tree (Name (Par)));
- Set_Expression (New_Then, Relocate_Node (Thenx));
-
- -- If the expression is itself a conditional expression whose
- -- expansion has been delayed, analyze it again and expand it.
-
- if Is_Delayed_Conditional_Expression (Expression (New_Then)) then
- Unanalyze_Delayed_Conditional_Expression (Expression (New_Then));
- end if;
-
- New_Else := New_Copy (Par);
- Set_Sloc (New_Else, Sloc (Elsex));
- Set_Name (New_Else, New_Copy_Tree (Name (Par)));
- Set_Expression (New_Else, Relocate_Node (Elsex));
-
- if Is_Delayed_Conditional_Expression (Expression (New_Else)) then
- Unanalyze_Delayed_Conditional_Expression (Expression (New_Else));
- end if;
+ New_Then := New_Assign_Copy (Par, Relocate_Node (Thenx));
+ New_Else := New_Assign_Copy (Par, Relocate_Node (Elsex));
If_Stmt :=
Make_Implicit_If_Statement (N,
@@ -14223,6 +14203,39 @@ package body Exp_Ch4 is
end if;
end Narrow_Large_Operation;
+ ---------------------
+ -- New_Assign_Copy --
+ ---------------------
+
+ function New_Assign_Copy (N : Node_Id; Expr : Node_Id) return Node_Id is
+ New_N : constant Node_Id := New_Copy (N);
+
+ begin
+ Set_Sloc (New_N, Sloc (Expr));
+ Set_Name (New_N, New_Copy_Tree (Name (N)));
+ Set_Expression (New_N, Expr);
+
+ -- The result of a function call need not be adjusted if it has
+ -- already been adjusted in the called function.
+
+ if No_Finalize_Actions (New_N)
+ and then Back_End_Return_Slot
+ and then Nkind (Expr) = N_Function_Call
+ then
+ Set_No_Finalize_Actions (New_N, False);
+ Set_No_Ctrl_Actions (New_N);
+ end if;
+
+ -- If the expression is itself a conditional expression whose
+ -- expansion has been delayed, analyze it again and expand it.
+
+ if Is_Delayed_Conditional_Expression (Expr) then
+ Unanalyze_Delayed_Conditional_Expression (Expr);
+ end if;
+
+ return New_N;
+ end New_Assign_Copy;
+
--------------------------------
-- Optimize_Length_Comparison --
--------------------------------
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 2a246adbb8a..26302baad64 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -289,8 +289,8 @@ package body Exp_Ch6 is
-- denoted by the call needs finalization in the current subprogram, which
-- excludes return statements, and is not identified with another object
-- that will be finalized, which excludes (statically) declared objects,
- -- dynamically allocated objects, and targets of assignments that are done
- -- directly (without intermediate temporaries).
+ -- dynamically allocated objects, components of aggregates, and targets of
+ -- assignments that are done directly (without intermediate temporaries).
procedure Expand_Non_Function_Return (N : Node_Id);
-- Expand a simple return statement found in a procedure body, entry body,
@@ -5365,7 +5365,7 @@ package body Exp_Ch6 is
-- to copy/readjust/finalize, we can just pass the value through (see
-- Expand_N_Simple_Return_Statement), and thus no attachment is needed.
-- Note that simple return statements are distributed into conditional
- -- expressions but we may be invoked before this distribution is done.
+ -- expressions, but we may be invoked before this distribution is done.
if Nkind (Uncond_Par) = N_Simple_Return_Statement then
return;
@@ -5386,7 +5386,7 @@ package body Exp_Ch6 is
end if;
-- Note that object declarations are also distributed into conditional
- -- expressions but we may be invoked before this distribution is done.
+ -- expressions, but we may be invoked before this distribution is done.
elsif Nkind (Uncond_Par) = N_Object_Declaration then
return;
@@ -5402,6 +5402,16 @@ package body Exp_Ch6 is
return;
end if;
+ -- Another optimization: if the returned value is used to initialize the
+ -- component of an aggregate, then no need to copy/readjust/finalize, we
+ -- can initialize it in place. Note that assignments for aggregates are
+ -- also distributed into conditional expressions, but we may be invoked
+ -- before this distribution is done.
+
+ if Parent_Is_Regular_Aggregate (Uncond_Par) then
+ return;
+ end if;
+
-- Avoid expansion to catch the error when the function call is on the
-- left-hand side of an assignment. Likewise if it is on the right-hand
-- side and no controlling actions will be performed for the assignment,
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index a62b7013d70..5322dea410b 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2709,6 +2709,15 @@ package body Sem_Util is
Append_Unique_Elmt (N, Identifiers_List);
end if;
+
+ -- Skip attribute references created by the compiler, typically
+ -- 'Constrained applied to one of the writable actuals, to avoid
+ -- spurious errors.
+
+ elsif Nkind (N) = N_Attribute_Reference
+ and then not Comes_From_Source (N)
+ then
+ return Skip;
end if;
return OK;
--
2.43.0
