From: Eric Botcazou <ebotca...@adacore.com>
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 object being
elaborated in the nonlimited by-reference case.
That's already not done in the nonlimited non-by-reference case and there is
no reason to do it in the former case either. The main issue are the calls
to Remove_Side_Effects in Expand_Ctrl_Function_Call (controlled case only)
and in Expand_N_Assignment_Statement, which serve various purposes including
very technical ones beside removing side effects.
The change is therefore very conservative and only removes the copy in the
case of a naked function call for the time being.
gcc/ada/ChangeLog:
* einfo.ads (Returns_By_Ref): Fix description.
* exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): Do not
adjust the component manually (if need be), set No_Finalize_Actions
instead of No_Ctrl_Actions for this purpose. Do not adjust when
the expression is a naked function call.
* exp_ch5.adb (Make_Tag_Ctrl_Assignment): Document the quirks of
the function. Assert that the LHS of the assignment does not have
side effects and replace calls to Duplicate_Subexpr_No_Checks with
calls to New_Copy_Tree. Rename local variable Asn to New_N.
(Expand_N_Assignment_Statement): In the tagged or controlled record
case, do remove side effects from both operands on entry. Remove
them in the controlled record case, except if the RHS is a function
call and the assignment has the No_Ctrl_Actions flag set.
* exp_ch6.adb (Expand_Ctrl_Function_Call): Bail out when the parent
node is an assignment statement with the No_Ctrl_Actions flag set.
* sem_util.adb (Statically_Different): Return True for a function
call that does not return its result by reference.
* sinfo.ads (No_Ctrl_Actions): Adjust description and add a note for
the code generator.
(No_Finalize_Actions): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/einfo.ads | 4 +-
gcc/ada/exp_ch3.adb | 80 +++++++++++-------------
gcc/ada/exp_ch5.adb | 143 ++++++++++++++++++++++++++-----------------
gcc/ada/exp_ch6.adb | 21 +++++--
gcc/ada/sem_util.adb | 28 +++++++--
gcc/ada/sinfo.ads | 22 ++++---
6 files changed, 180 insertions(+), 118 deletions(-)
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index d283358c0c0..1946e68b3c7 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -4278,8 +4278,8 @@ package Einfo is
-- Returns_By_Ref
-- Defined in subprogram type entities and functions. Set if a function
--- (or an access-to-function type) returns a result by reference, either
--- because the result is built in place, or its type is by-reference.
+-- (or a function type) returns a result by reference, either because the
+-- result is built in place or its type is limited in Ada 95.
-- Reverse_Bit_Order [base type only]
-- Defined in all record type entities. Set if entity has a Bit_Order
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 9419d5d2fac..65d8eb7c433 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -2618,11 +2618,10 @@ package body Exp_Ch3 is
Default_Loc : constant Source_Ptr := Sloc (Default);
Typ : constant Entity_Id := Underlying_Type (Etype (Id));
- Adj_Call : Node_Id;
- Exp : Node_Id;
- Exp_Q : Node_Id;
- Lhs : Node_Id;
- Res : List_Id;
+ Exp : Node_Id;
+ Exp_Q : Node_Id;
+ Lhs : Node_Id;
+ Res : List_Id;
begin
Lhs :=
@@ -2677,57 +2676,48 @@ package body Exp_Ch3 is
Name => Lhs,
Expression => Exp));
- Set_No_Ctrl_Actions (First (Res));
-
Exp_Q := Unqualify (Exp);
- -- Adjust the tag if tagged (because of possible view conversions).
- -- Suppress the tag adjustment when not Tagged_Type_Expansion because
- -- tags are represented implicitly in objects, and when the record is
- -- initialized with a raise expression.
-
- if Is_Tagged_Type (Typ)
- and then Tagged_Type_Expansion
- and then Nkind (Exp_Q) /= N_Raise_Expression
- then
- -- Get the relevant type for the call to
- -- Make_Tag_Assignment_From_Type, which, for concurrent types is
- -- their corresponding record.
-
- declare
- T : Entity_Id := Underlying_Type (Typ);
- begin
- if Ekind (T) in E_Protected_Type | E_Task_Type then
- T := Corresponding_Record_Type (T);
- end if;
-
- Append_To (Res,
- Make_Tag_Assignment_From_Type
- (Default_Loc,
- New_Copy_Tree (Lhs, New_Scope => Proc_Id),
- T));
- end;
- end if;
-
- -- Adjust the component if controlled except if it is an aggregate
+ -- 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).
+ -- aggregates does require component adjustment), or a function call.
+ -- 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.
if Needs_Finalization (Typ)
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
then
- Adj_Call :=
- Make_Adjust_Call
- (Obj_Ref => New_Copy_Tree (Lhs),
- Typ => Etype (Id));
+ Set_No_Finalize_Actions (First (Res));
+
+ else
+ Set_No_Ctrl_Actions (First (Res));
+
+ -- Adjust the tag if tagged because of possible view conversions
+
+ if Is_Tagged_Type (Typ)
+ and then Tagged_Type_Expansion
+ and then Nkind (Exp_Q) /= N_Raise_Expression
+ then
+ declare
+ Utyp : Entity_Id := Underlying_Type (Typ);
+
+ begin
+ -- Get the relevant type for Make_Tag_Assignment_From_Type,
+ -- which, for concurrent types is the corresponding record.
- -- Guard against a missing [Deep_]Adjust when the component type
- -- was not properly frozen.
+ if Ekind (Utyp) in E_Protected_Type | E_Task_Type then
+ Utyp := Corresponding_Record_Type (Utyp);
+ end if;
- if Present (Adj_Call) then
- Append_To (Res, Adj_Call);
+ Append_To (Res,
+ Make_Tag_Assignment_From_Type (Default_Loc,
+ New_Copy_Tree (Lhs, New_Scope => Proc_Id),
+ Utyp));
+ end;
end if;
end if;
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 5bd61ba214d..39b26e0e9b6 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -196,9 +196,14 @@ package body Exp_Ch5 is
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
-- Generate the necessary code for controlled and tagged assignment, that
-- is to say, finalization of the target before, adjustment of the target
- -- after and save and restore of the tag and finalization pointers which
- -- are not 'part of the value' and must not be changed upon assignment. N
- -- is the original Assignment node.
+ -- after, and save and restore of the tag. N is the original assignment.
+
+ -- Note that the function relocates N and adds it to the list result, which
+ -- means that the subtrees of N are effectively detached from the main tree
+ -- until after the list result is inserted into it. That's why inserting
+ -- actions in them and, in particular, removing side effects will not work
+ -- properly. Therefore, this must be done before invoking the function, and
+ -- it assumes that side effects have been removed from the Name of N.
--------------------------------------
-- Build_Formal_Container_Iteration --
@@ -2963,19 +2968,13 @@ package body Exp_Ch5 is
or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ))
then
Tagged_Case : declare
- L : List_Id := No_List;
Expand_Ctrl_Actions : constant Boolean :=
not No_Ctrl_Actions (N)
and then not No_Finalize_Actions (N);
- begin
- -- In the controlled case, we ensure that function calls are
- -- evaluated before finalizing the target. In all cases, it makes
- -- the expansion easier if the side effects are removed first.
-
- Remove_Side_Effects (Lhs);
- Remove_Side_Effects (Rhs);
+ L : List_Id := No_List;
+ begin
-- Avoid recursion in the mechanism
Set_Analyzed (N);
@@ -3162,40 +3161,70 @@ package body Exp_Ch5 is
end;
end;
+ -- Untagged case
+
else
- L := Make_Tag_Ctrl_Assignment (N);
+ declare
+ Needs_Self_Protection : constant Boolean :=
+ Expand_Ctrl_Actions
+ and then not Restriction_Active (No_Finalization)
+ and then not Statically_Different (Lhs, Rhs);
+ -- We can't afford to have destructive finalization actions
+ -- in the self-assignment case, so if the target and source
+ -- are not obviously different, we generate code to avoid
+ -- the self-assignment case altogether.
- -- We can't afford to have destructive Finalization Actions in
- -- the Self assignment case, so if the target and the source
- -- are not obviously different, code is generated to avoid the
- -- self assignment case:
+ begin
+ -- See the description of Make_Tag_Ctrl_Assignment
- -- if lhs'address /= rhs'address then
- -- <code for controlled and/or tagged assignment>
- -- end if;
+ Remove_Side_Effects (Lhs);
- -- Skip this if Restriction (No_Finalization) is active
+ -- Logically we would only need to remove side effects from
+ -- the RHS when the protection against self-assignment will
+ -- be generated below. However, in some very specific cases
+ -- like Present (Unqual_BIP_Iface_Function_Call (Rhs)), the
+ -- creation of the temporary is necessary to enable further
+ -- expansion of the RHS. Therefore, we take a conservative
+ -- stance and always do it for the time being, except when
+ -- Expand_Ctrl_Function_Call does not do it either.
- if not Statically_Different (Lhs, Rhs)
- and then Expand_Ctrl_Actions
- and then not Restriction_Active (No_Finalization)
- then
- L := New_List (
- Make_Implicit_If_Statement (N,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Lhs),
- Attribute_Name => Name_Address),
-
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Rhs),
- Attribute_Name => Name_Address)),
-
- Then_Statements => L));
- end if;
+ if Nkind (Rhs) = N_Function_Call
+ and then No_Ctrl_Actions (N)
+ then
+ -- We should not need protection against self-assignment
+ -- in the case of a function call
+
+ pragma Assert (not Needs_Self_Protection);
+
+ else
+ Remove_Side_Effects (Rhs);
+ end if;
+
+ L := Make_Tag_Ctrl_Assignment (N);
+
+ -- Generate:
+ -- if Lhs'Address /= Rhs'Address then
+ -- <code for controlled and/or tagged assignment>
+ -- end if;
+
+ if Needs_Self_Protection then
+ L := New_List (
+ Make_Implicit_If_Statement (N,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Lhs),
+ Attribute_Name => Name_Address),
+
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Rhs),
+ Attribute_Name => Name_Address)),
+
+ Then_Statements => L));
+ end if;
+ end;
-- We need to set up an exception handler for implementing
-- 7.6.1(18), but this is skipped if the type has relaxed
@@ -3215,11 +3244,16 @@ package body Exp_Ch5 is
end if;
end if;
+ -- No need for a block if there are no controlling actions
+
+ if No_Ctrl_Actions (N) and then List_Length (L) = 1 then
+ Rewrite (N, Remove_Head (L));
+
-- We will analyze the block statement with all checks suppressed
-- below, but we need elaboration checks for the primitives in the
-- case of an assignment created by the expansion of an aggregate.
- if No_Finalize_Actions (N) then
+ elsif No_Finalize_Actions (N) then
Rewrite (N,
Make_Unsuppress_Block (Loc, Name_Elaboration_Check, L));
@@ -6332,7 +6366,6 @@ package body Exp_Ch5 is
------------------------------
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id is
- Asn : constant Node_Id := Relocate_Node (N);
L : constant Node_Id := Name (N);
Loc : constant Source_Ptr := Sloc (N);
Res : constant List_Id := New_List;
@@ -6355,9 +6388,12 @@ package body Exp_Ch5 is
and then Tagged_Type_Expansion;
Adj_Call : Node_Id;
Fin_Call : Node_Id;
+ New_N : Node_Id;
Tag_Id : Entity_Id;
begin
+ pragma Assert (Side_Effect_Free (L));
+
-- Finalize the target of the assignment when controlled
-- We have two exceptions here:
@@ -6389,9 +6425,7 @@ package body Exp_Ch5 is
else
Fin_Call :=
- Make_Final_Call
- (Obj_Ref => Duplicate_Subexpr_No_Checks (L),
- Typ => Etype (L));
+ Make_Final_Call (Obj_Ref => New_Copy_Tree (L), Typ => Etype (L));
if Present (Fin_Call) then
Append_To (Res, Fin_Call);
@@ -6409,7 +6443,7 @@ package body Exp_Ch5 is
Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
Expression =>
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr_No_Checks (L),
+ Prefix => New_Copy_Tree (L),
Selector_Name =>
New_Occurrence_Of (First_Tag_Component (T), Loc))));
@@ -6424,12 +6458,14 @@ package body Exp_Ch5 is
-- generate the proper code and propagate this scenario by setting a
-- flag to avoid infinite recursion.
+ New_N := Relocate_Node (N);
+
if Comp_Asn then
- Set_Analyzed (Asn, False);
- Set_Componentwise_Assignment (Asn, True);
+ Set_Analyzed (New_N, False);
+ Set_Componentwise_Assignment (New_N, True);
end if;
- Append_To (Res, Asn);
+ Append_To (Res, New_N);
-- Restore the tag
@@ -6438,7 +6474,7 @@ package body Exp_Ch5 is
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr_No_Checks (L),
+ Prefix => New_Copy_Tree (L),
Selector_Name =>
New_Occurrence_Of (First_Tag_Component (T), Loc)),
Expression => New_Occurrence_Of (Tag_Id, Loc)));
@@ -6447,8 +6483,7 @@ package body Exp_Ch5 is
elsif Set_Tag then
Append_To (Res,
- Make_Tag_Assignment_From_Type
- (Loc, Duplicate_Subexpr_No_Checks (L), T));
+ Make_Tag_Assignment_From_Type (Loc, New_Copy_Tree (L), T));
end if;
-- Adjust the target after the assignment when controlled (not in the
@@ -6456,9 +6491,7 @@ package body Exp_Ch5 is
if Ctrl_Act or else Adj_Act then
Adj_Call :=
- Make_Adjust_Call
- (Obj_Ref => Duplicate_Subexpr_Move_Checks (L),
- Typ => Etype (L));
+ Make_Adjust_Call (Obj_Ref => New_Copy_Tree (L), Typ => Etype (L));
if Present (Adj_Call) then
Append_To (Res, Adj_Call);
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index e6e5d50dbbf..11b954fbabd 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -281,10 +281,17 @@ package body Exp_Ch6 is
-- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals.
procedure Expand_Ctrl_Function_Call (N : Node_Id; Use_Sec_Stack : Boolean);
- -- N is a function call which returns a controlled object. Transform the
+ -- N is a function call that returns a controlled object. Transform the
-- call into a temporary which retrieves the returned object from the
-- primary or secondary stack (Use_Sec_Stack says which) using 'reference.
+ -- This expansion is necessary in all the cases where the constant object
+ -- 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).
+
procedure Expand_Non_Function_Return (N : Node_Id);
-- Expand a simple return statement found in a procedure body, entry body,
-- accept statement, or an extended return statement. Note that all non-
@@ -5406,9 +5413,15 @@ package body Exp_Ch6 is
end if;
-- Avoid expansion to catch the error when the function call is on the
- -- left-hand side of an assignment.
-
- if Nkind (Par) = N_Assignment_Statement and then N = Name (Par) then
+ -- 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,
+ -- which means that this is an initialization of the target and it can
+ -- thus be performed directly. Note that the code generator should also
+ -- avoid creating a temporary for the right-hand side in this case.
+
+ if Nkind (Par) = N_Assignment_Statement
+ and then (N = Name (Par) or else No_Ctrl_Actions (Par))
+ then
return;
end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index c1af2281a22..595d3d10d0f 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -28309,11 +28309,29 @@ package body Sem_Util is
R1 : constant Node_Id := Get_Referenced_Object (E1);
R2 : constant Node_Id := Get_Referenced_Object (E2);
begin
- return Is_Entity_Name (R1)
- and then Is_Entity_Name (R2)
- and then Entity (R1) /= Entity (R2)
- and then not Is_Formal (Entity (R1))
- and then not Is_Formal (Entity (R2));
+ -- Two identifiers are statically different if they denote different
+ -- entities that are not formal parameters.
+
+ if Is_Entity_Name (R1) and then Is_Entity_Name (R2) then
+ return Entity (R1) /= Entity (R2)
+ and then not Is_Formal (Entity (R1))
+ and then not Is_Formal (Entity (R2));
+
+ -- A function call that does not return its result by reference denotes
+ -- a constant object that is statically different from anything else.
+
+ elsif (Nkind (R1) = N_Function_Call
+ and then Is_Entity_Name (Name (R1))
+ and then not Returns_By_Ref (Entity (Name (R1))))
+ or else (Nkind (R2) = N_Function_Call
+ and then Is_Entity_Name (Name (R2))
+ and then not Returns_By_Ref (Entity (Name (R2))))
+ then
+ return R1 /= R2;
+
+ else
+ return False;
+ end if;
end Statically_Different;
-----------------------------
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index a092fdf786d..2e1ac250c93 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1770,7 +1770,7 @@ package Sinfo is
-- in interpolated expressions.
-- Is_Known_Guaranteed_ABE
- -- NOTE: this flag is shared between the legacy ABE mechanism and the
+ -- Note: this flag is shared between the legacy ABE mechanism and the
-- default ABE mechanism.
--
-- Present in the following nodes:
@@ -2058,14 +2058,18 @@ package Sinfo is
-- Present in N_Assignment_Statement to indicate that neither Finalize
-- nor Adjust should take place on this assignment even though the LHS
-- and RHS are controlled. Also to indicate that the primitive _assign
- -- should not be used for a tagged assignment. This flag is used in init
- -- proc and aggregate expansion where the generated assignments are
+ -- should not be used for a tagged assignment. This flag is only used
+ -- in initialization procedures, and the expansion of aggregates, object
+ -- declarations and allocators, where the generated assignments are
-- initializations, not real assignments. Note that it also suppresses
-- the creation of transient scopes around the N_Assignment_Statement,
-- in other words it disables all controlled actions for the assignment.
+ -- Additional note: the code generator should avoid creating a temporary
+ -- for the RHS when this flag is set on the N_Assignment_Statement node,
+ -- including when this RHS is a function call.
-- No_Elaboration_Check
- -- NOTE: this flag is relevant only for the legacy ABE mechanism and
+ -- Note: this flag is relevant only for the legacy ABE mechanism and
-- should not be used outside of that context.
--
-- Present in N_Function_Call and N_Procedure_Call_Statement. Indicates
@@ -2086,10 +2090,14 @@ package Sinfo is
-- Present in N_Assignment_Statement to indicate that no Finalize should
-- take place on this assignment even though the LHS is controlled. Also
-- to indicate that the primitive _assign should not be used for a tagged
- -- assignment. This flag is only used in aggregates expansion where the
- -- generated assignments are initializations, not real assignments. Note
- -- that, unlike the No_Ctrl_Actions flag, it does *not* suppress the
+ -- assignment. This flag is only used in initialization procedures, and
+ -- the expansion of aggregates, object declarations and allocators, where
+ -- the generated assignments are initializations, not real assignments.
+ -- Note that, unlike No_Ctrl_Actions, this flag does *not* suppress the
-- creation of transient scopes around the N_Assignment_Statement.
+ -- Additional note: the code generator should avoid creating a temporary
+ -- for the RHS when this flag is set on the N_Assignment_Statement node,
+ -- including when this RHS is a function call.
-- No_Initialization
-- Present in N_Object_Declaration and N_Allocator to indicate that the
--
2.43.0
