https://gcc.gnu.org/g:1e3619a37aebd8005c8505aebded7957b661577c
commit r15-6518-g1e3619a37aebd8005c8505aebded7957b661577c
Author: Eric Botcazou <ebotca...@adacore.com>
Date: Mon Dec 2 21:58:29 2024 +0100
ada: Improve expansion of conditional expressions in object declarations
This arranges for conditional expressions in objects declarations to have
their expansion delayed when they have a type that cannot be easily copied
or copied at all, including limited and controlled types.
The ultimate goal is to replace the declaration with a renaming declaration
of the dereference of an access value designating an object initialized with
the dependent expression chosen by the condition.
gcc/ada/ChangeLog:
* einfo.ads (Is_Independent): Document usage on Master_Node objects.
* exp_aggr.adb (In_Place_Assign_OK): Remove Parent_Kind variable.
(Convert_To_Assignments): Call Unconditional_Parent and remove the
restriction on the known size for the in-place expansion of the
aggregate in the context of an object declaration.
(Expand_Array_Aggregate): Remove Parent_Kind variable and call
Unconditional_Parent and Delay_Conditional_Expressions_Between
* exp_ch3.adb: Remove clauses for Exp_Dbug.
(Expand_N_Object_Declaration): Factor out the code rewriting the
declaration as a renaming in Rewrite_Object_Declaration_As_Renaming
and call the procedure.
* exp_ch4.adb (Insert_Conditional_Object_Declaration): Declare.
(Expand_N_Case_Expression): Delay expanding the expression if it is
in the context of an optimizable object declaration. If the parent
node is this object declaration, then replace it with a renaming of
the dereference of an access value designating an object initialized
with the dependent expression chosen by the condition.
(Expand_N_If_Expression): Likewise.
(Insert_Conditional_Object_Declaration): New procedure.
* exp_ch6.adb (Expand_Ctrl_Function_Call): Test the unconditional
parent in the case of an object declaration too.
* exp_ch7.adb (Build_Finalizer.Process_Declarations): Pass Strict to
Processing_Actions from the Is_Independent flag on a Master_Node.
* exp_util.ads (Rewrite_Object_Declaration_As_Renaming): Declare.
* exp_util.adb: Add clauses for Exp_Dbug.
(Rewrite_Object_Declaration_As_Renaming): New procedure extracted
from Expand_N_Object_Declaration.
* sem_ch3.adb (Analyze_Object_Declaration): Also leave the analysis
if the declaration has been replaced with a renaming in the case of
an initialization expression that is a conditional expression.
Diff:
---
gcc/ada/einfo.ads | 4 +
gcc/ada/exp_aggr.adb | 123 +++++------------
gcc/ada/exp_ch3.adb | 31 +----
gcc/ada/exp_ch4.adb | 368 +++++++++++++++++++++++++++++++++++++++++++++++----
gcc/ada/exp_ch6.adb | 14 +-
gcc/ada/exp_ch7.adb | 3 +-
gcc/ada/exp_util.adb | 41 ++++++
gcc/ada/exp_util.ads | 3 +
gcc/ada/sem_ch3.adb | 15 ++-
9 files changed, 455 insertions(+), 147 deletions(-)
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 1a8760c0dbb1..025465265f3c 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -2804,6 +2804,10 @@ package Einfo is
-- case of private and incomplete types, this flag is set in both the
-- partial view and the full view.
+-- This flag is also set on the Master_Node objects generated by the
+-- compiler (see Finalization_Master_Node above) to indicate that the
+-- associated finalizable object has relaxed finalization semantics.
+
-- Is_Initial_Condition_Procedure
-- Defined in functions and procedures. Set for a generated procedure
-- which verifies the assumption of pragma Initial_Condition at run time.
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 344e4d10c5f6..1f1f58061cee 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -4119,7 +4119,6 @@ package body Exp_Aggr is
-- Local variables
- Parent_Kind : Node_Kind;
Parent_Node : Node_Id;
-- Start of processing for In_Place_Assign_OK
@@ -4132,11 +4131,9 @@ package body Exp_Aggr is
end if;
Parent_Node := Parent (N);
- Parent_Kind := Nkind (Parent_Node);
- if Parent_Kind = N_Qualified_Expression then
+ if Nkind (Parent_Node) = N_Qualified_Expression then
Parent_Node := Parent (Parent_Node);
- Parent_Kind := Nkind (Parent_Node);
end if;
-- On assignment, sliding can take place, so we cannot do the
@@ -4161,44 +4158,11 @@ package body Exp_Aggr is
procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
- function Known_Size (Decl : Node_Id; Cond_Init : Boolean) return Boolean;
- -- Decl is an N_Object_Declaration node. Return true if it declares an
- -- object with a known size; in this context, that is always the case,
- -- except for a declaration without explicit constraints of an object,
- -- either whose nominal subtype is class-wide, or whose initialization
- -- contains a conditional expression and whose nominal subtype is both
- -- discriminated and unconstrained.
-
- ----------------
- -- Known_Size --
- ----------------
-
- function Known_Size (Decl : Node_Id; Cond_Init : Boolean) return Boolean
- is
- begin
- if Is_Entity_Name (Object_Definition (Decl)) then
- declare
- Typ : constant Entity_Id := Entity (Object_Definition (Decl));
-
- begin
- return not Is_Class_Wide_Type (Typ)
- and then not (Cond_Init
- and then Has_Discriminants (Typ)
- and then not Is_Constrained (Typ));
- end;
-
- else
- return True;
- end if;
- end Known_Size;
-
-- Local variables
Aggr_Code : List_Id;
Full_Typ : Entity_Id;
- In_Cond_Expr : Boolean;
Instr : Node_Id;
- Node : Node_Id;
Parent_Node : Node_Id;
Target_Expr : Node_Id;
Temp : Entity_Id;
@@ -4210,40 +4174,11 @@ package body Exp_Aggr is
pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N));
pragma Assert (Is_Record_Type (Typ));
- In_Cond_Expr := False;
- Node := N;
- Parent_Node := Parent (Node);
-
- -- First, climb the parent chain, looking through qualified expressions
- -- and dependent expressions of conditional expressions.
-
- loop
- case Nkind (Parent_Node) is
- when N_Case_Expression_Alternative =>
- null;
-
- when N_Case_Expression =>
- exit when Node = Expression (Parent_Node);
- In_Cond_Expr := True;
-
- when N_If_Expression =>
- exit when Node = First (Expressions (Parent_Node));
- In_Cond_Expr := True;
-
- when N_Qualified_Expression =>
- null;
-
- when others =>
- exit;
- end case;
-
- Node := Parent_Node;
- Parent_Node := Parent (Node);
- end loop;
-
-- Set the Expansion_Delayed flag in the cases where the transformation
-- will be done top down from above.
+ Parent_Node := Unconditional_Parent (N);
+
if
-- Internal aggregates (transformed when expanding the parent),
-- excluding container aggregates as these are transformed into
@@ -4259,11 +4194,15 @@ package body Exp_Aggr is
or else Nkind (Parent_Node) = N_Allocator
- -- Object declaration (see Convert_Aggr_In_Object_Decl). So far only
- -- declarations with a known size are supported.
+ -- Object declaration (see Convert_Aggr_In_Object_Decl). Class-wide
+ -- declarations are excluded so far.
or else (Nkind (Parent_Node) = N_Object_Declaration
- and then Known_Size (Parent_Node, In_Cond_Expr))
+ and then not
+ (Is_Entity_Name (Object_Definition (Parent_Node))
+ and then
+ Is_Class_Wide_Type
+ (Entity (Object_Definition (Parent_Node)))))
-- Safe assignment (see Convert_Aggr_In_Assignment). So far only the
-- assignments in init procs are taken into account.
@@ -5894,7 +5833,6 @@ package body Exp_Aggr is
-- Holds the declaration of Tmp
Parent_Node : Node_Id;
- Parent_Kind : Node_Kind;
-- Start of processing for Expand_Array_Aggregate
@@ -6110,13 +6048,7 @@ package body Exp_Aggr is
-- Set the Expansion_Delayed flag in the cases where the transformation
-- will be done top down from above.
- Parent_Node := Parent (N);
- Parent_Kind := Nkind (Parent_Node);
-
- if Parent_Kind = N_Qualified_Expression then
- Parent_Node := Parent (Parent_Node);
- Parent_Kind := Nkind (Parent_Node);
- end if;
+ Parent_Node := Unconditional_Parent (N);
if
-- Internal aggregates (transformed when expanding the parent),
@@ -6124,10 +6056,10 @@ package body Exp_Aggr is
-- subprogram calls later. So far aggregates with self-references
-- are not supported if they appear in a conditional expression.
- (Parent_Kind = N_Component_Association
+ (Nkind (Parent_Node) = N_Component_Association
and then not Is_Container_Aggregate (Parent (Parent_Node)))
- or else (Parent_Kind in N_Aggregate | N_Extension_Aggregate
+ or else (Nkind (Parent_Node) in N_Aggregate | N_Extension_Aggregate
and then not Is_Container_Aggregate (Parent_Node))
-- Allocator (see Convert_Aggr_In_Allocator). Sliding cannot be done
@@ -6146,7 +6078,7 @@ package body Exp_Aggr is
-- Object declaration (see Convert_Aggr_In_Object_Decl). Sliding
-- cannot be done in place for the time being.
- or else (Parent_Kind = N_Object_Declaration
+ or else (Nkind (Parent_Node) = N_Object_Declaration
and then
(Aggr_Assignment_OK_For_Backend (N)
or else Is_Limited_Type (Typ)
@@ -6163,7 +6095,7 @@ package body Exp_Aggr is
-- assignments in init procs are taken into account, as well those
-- directly performed by the back end.
- or else (Parent_Kind = N_Assignment_Statement
+ or else (Nkind (Parent_Node) = N_Assignment_Statement
and then
(Inside_Init_Proc
or else
@@ -6174,7 +6106,16 @@ package body Exp_Aggr is
or else Is_Build_In_Place_Aggregate_Return (Parent_Node)
then
- Set_Expansion_Delayed (N, not Static_Array_Aggregate (N));
+ if not Static_Array_Aggregate (N) then
+ -- Mark the aggregate, as well as all the intermediate conditional
+ -- expressions, as having expansion delayed. This will block the
+ -- usual (bottom-up) expansion of the marked nodes and replace it
+ -- with a top-down expansion from the parent node.
+
+ Set_Expansion_Delayed (N);
+ Delay_Conditional_Expressions_Between (N, Parent_Node);
+ end if;
+
return;
end if;
@@ -6184,6 +6125,14 @@ package body Exp_Aggr is
Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
+ -- Now get back to the immediate parent, modulo qualified expression
+
+ Parent_Node := Parent (N);
+
+ if Nkind (Parent_Node) = N_Qualified_Expression then
+ Parent_Node := Parent (Parent_Node);
+ end if;
+
-- STEP 5
-- Check whether in-place aggregate expansion is possible
@@ -6193,7 +6142,7 @@ package body Exp_Aggr is
-- protected objects or tasks. For other cases we create a temporary.
Maybe_In_Place_OK :=
- Parent_Kind = N_Assignment_Statement
+ Nkind (Parent_Node) = N_Assignment_Statement
and then (Is_Limited_Type (Typ)
or else (not Has_Default_Init_Comps (N)
and then not Is_Bit_Packed_Array (Typ)
@@ -6259,14 +6208,14 @@ package body Exp_Aggr is
-- around the aggregate for this purpose.
if Ekind (Current_Scope) = E_Loop
- and then Parent_Kind = N_Allocator
+ and then Nkind (Parent_Node) = N_Allocator
then
Establish_Transient_Scope (N, Manage_Sec_Stack => False);
-- If the parent is an assignment for which no controlled actions
-- should take place, prevent the temporary from being finalized.
- elsif Parent_Kind = N_Assignment_Statement
+ elsif Nkind (Parent_Node) = N_Assignment_Statement
and then No_Ctrl_Actions (Parent_Node)
then
Mutate_Ekind (Tmp, E_Variable);
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 2a0b0e606b4f..afcb0a9d328f 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -38,7 +38,6 @@ with Exp_Ch4; use Exp_Ch4;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
-with Exp_Dbug; use Exp_Dbug;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Put_Image;
@@ -9134,35 +9133,7 @@ package body Exp_Ch3 is
-- illegal code if written by hand, but that's OK.
if Rewrite_As_Renaming then
- Rewrite (N,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Mark => New_Occurrence_Of (Etype (Def_Id), Loc),
- Name => Expr_Q));
-
- -- Keep original aspects
-
- Move_Aspects (Original_Node (N), N);
-
- -- We do not analyze this renaming declaration, because all its
- -- components have already been analyzed, and if we were to go
- -- ahead and analyze it, we would in effect be trying to generate
- -- another declaration of X, which won't do.
-
- Set_Renamed_Object (Def_Id, Expr_Q);
- Set_Analyzed (N);
-
- -- We do need to deal with debug issues for this renaming
-
- -- First, if entity comes from source, then mark it as needing
- -- debug information, even though it is defined by a generated
- -- renaming that does not come from source.
-
- Set_Debug_Info_Defining_Id (N);
-
- -- Now call the routine to generate debug info for the renaming
-
- Insert_Action (N, Debug_Renaming_Declaration (N));
+ Rewrite_Object_Declaration_As_Renaming (N, Expr_Q);
end if;
-- Exception on library entity not available
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 7fda62216612..8db729f0ce92 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -191,6 +191,15 @@ package body Exp_Ch4 is
-- Return the size of a small signed integer type covering Lo .. Hi, the
-- main goal being to return a size lower than that of standard types.
+ procedure Insert_Conditional_Object_Declaration
+ (Obj_Id : Entity_Id;
+ Expr : Node_Id;
+ Decl : Node_Id);
+ -- Expr is the dependent expression of a conditional expression and Decl
+ -- is the declaration of an object whose initialization expression is the
+ -- conditional expression. Insert in the actions of Expr the declaration
+ -- of Obj_Id modeled on Decl and with Expr as initialization expression.
+
procedure Insert_Dereference_Action (N : Node_Id);
-- N is an expression whose type is an access. When the type of the
-- associated storage pool is derived from Checked_Pool, generate a
@@ -4259,7 +4268,7 @@ package body Exp_Ch4 is
function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
Idx : Node_Id := First_Index (E);
- Len : Node_Id;
+ Len : Node_Id := Empty;
Res : Node_Id := Empty;
begin
@@ -4987,6 +4996,9 @@ package body Exp_Ch4 is
-- Return True if we can copy objects of this type when expanding a case
-- expression.
+ function Is_Optimizable_Declaration (N : Node_Id) return Boolean;
+ -- Return True if N is an object declaration that can be optimized
+
------------------
-- Is_Copy_Type --
------------------
@@ -4996,12 +5008,28 @@ package body Exp_Ch4 is
return Is_Elementary_Type (Underlying_Type (Typ));
end Is_Copy_Type;
+ --------------------------------
+ -- Is_Optimizable_Declaration --
+ --------------------------------
+
+ function Is_Optimizable_Declaration (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Object_Declaration
+ and then not (Is_Entity_Name (Object_Definition (N))
+ and then Is_Class_Wide_Type
+ (Entity (Object_Definition (N))))
+ and then not Is_Return_Object (Defining_Identifier (N))
+ and then not Is_Copy_Type (Typ);
+ end Is_Optimizable_Declaration;
+
-- Local variables
Acts : List_Id;
Alt : Node_Id;
Case_Stmt : Node_Id;
Decl : Node_Id;
+ New_N : Node_Id;
+ Par_Obj : Node_Id;
Target : Entity_Id := Empty;
Target_Typ : Entity_Id;
@@ -5035,6 +5063,25 @@ package body Exp_Ch4 is
-- This makes the expansion much easier when expressions are calls to
-- build-in-place functions.
+ Optimize_Object_Decl : Boolean := False;
+ -- Small optimization: when the case expression appears in the context
+ -- of an object declaration of a type not Is_Copy_Type, expand into
+
+ -- case X is
+ -- when A =>
+ -- then-obj : typ := then_expr;
+ -- target := then-obj'Unrestricted_Access;
+ -- when B =>
+ -- else-obj : typ := else-expr;
+ -- target := else-obj'Unrestricted_Access;
+ -- ...
+ -- end case
+ --
+ -- obj : typ renames target.all;
+
+ -- This makes the expansion much easier when expressions are calls to
+ -- build-in-place functions.
+
-- Start of processing for Expand_N_Case_Expression
begin
@@ -5047,7 +5094,9 @@ package body Exp_Ch4 is
declare
Uncond_Par : constant Node_Id := Unconditional_Parent (N);
begin
- if Nkind (Uncond_Par) = N_Simple_Return_Statement then
+ if Nkind (Uncond_Par) = N_Simple_Return_Statement
+ or else Is_Optimizable_Declaration (Uncond_Par)
+ then
Delay_Conditional_Expressions_Between (N, Uncond_Par);
end if;
end;
@@ -5065,6 +5114,9 @@ package body Exp_Ch4 is
elsif Nkind (Par) = N_Simple_Return_Statement then
Optimize_Return_Stmt := True;
+ elsif Is_Optimizable_Declaration (Par) then
+ Optimize_Object_Decl := True;
+
else
return;
end if;
@@ -5148,7 +5200,7 @@ package body Exp_Ch4 is
-- No need for Target_Typ in the case of statements
if Optimize_Assignment_Stmt or else Optimize_Return_Stmt then
- null;
+ Target_Typ := Empty;
-- Scalar/Copy case
@@ -5159,7 +5211,7 @@ package body Exp_Ch4 is
-- 'Unrestricted_Access.
-- Generate:
- -- type Ptr_Typ is not null access all Typ;
+ -- type Ptr_Typ is not null access all [constant] Typ;
else
Target_Typ := Make_Temporary (Loc, 'P');
@@ -5171,7 +5223,9 @@ package body Exp_Ch4 is
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Null_Exclusion_Present => True,
- Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
+ Subtype_Indication => New_Occurrence_Of (Typ, Loc),
+ Constant_Present =>
+ Optimize_Object_Decl and then Constant_Present (Par))));
end if;
-- Create the declaration of the target which captures the value of the
@@ -5199,11 +5253,19 @@ package body Exp_Ch4 is
Alt := First (Alternatives (N));
while Present (Alt) loop
+ -- When the alternative's expression involves controlled function
+ -- calls, generated temporaries are chained on the corresponding
+ -- list of actions. These temporaries need to be finalized after
+ -- the case expression is evaluated.
+
+ Process_Transients_In_Expression (N, Actions (Alt));
+
declare
Alt_Loc : constant Source_Ptr := Sloc (Expression (Alt));
Alt_Expr : Node_Id := Relocate_Node (Expression (Alt));
LHS : Node_Id;
+ Obj : Node_Id;
Stmts : List_Id;
begin
@@ -5240,12 +5302,34 @@ package body Exp_Ch4 is
Unanalyze_Delayed_Conditional_Expression (Alt_Expr);
end if;
+ -- Generate:
+ -- Obj : [constant] Typ := AX;
+ -- Target := Obj'Unrestricted_Access;
+
+ elsif Optimize_Object_Decl then
+ Obj := Make_Temporary (Loc, 'C', Alt_Expr);
+
+ Insert_Conditional_Object_Declaration (Obj, Alt_Expr, Par);
+
+ Alt_Expr :=
+ Make_Attribute_Reference (Alt_Loc,
+ Prefix => New_Occurrence_Of (Obj, Alt_Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+
+ LHS := New_Occurrence_Of (Target, Loc);
+ Set_Assignment_OK (LHS);
+
+ Stmts := New_List (
+ Make_Assignment_Statement (Alt_Loc,
+ Name => LHS,
+ Expression => Alt_Expr));
+
-- Take the unrestricted access of the expression value for non-
-- scalar types. This approach avoids big copies and covers the
-- limited and unconstrained cases.
-- Generate:
- -- Target := AX['Unrestricted_Access];
+ -- Target := AX'Unrestricted_Access;
else
if not Is_Copy_Type (Typ) then
@@ -5288,12 +5372,6 @@ package body Exp_Ch4 is
Make_Case_Statement_Alternative (Sloc (Alt),
Discrete_Choices => Discrete_Choices (Alt),
Statements => Stmts));
-
- -- Finalize any transient objects on exit from the alternative.
- -- Note that this needs to be done only after Stmts is attached
- -- to the Alternatives list above (for Safe_To_Capture_Value).
-
- Process_Transients_In_Expression (N, Stmts);
end;
Next (Alt);
@@ -5305,24 +5383,48 @@ package body Exp_Ch4 is
Rewrite (Par, Case_Stmt);
Analyze (Par);
+ elsif Optimize_Object_Decl then
+ Append_To (Acts, Case_Stmt);
+ Insert_Actions (Par, Acts);
+
+ New_N :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Target, Loc));
+
+ -- The renaming is not analyzed so complete the decoration of the
+ -- object and set the type of the name directly.
+
+ Par_Obj := Defining_Identifier (Par);
+ if Constant_Present (Par) then
+ Mutate_Ekind (Par_Obj, E_Constant);
+ Set_Is_True_Constant (Par_Obj);
+ else
+ Mutate_Ekind (Par_Obj, E_Variable);
+ end if;
+
+ Set_Etype (New_N, Etype (Par_Obj));
+
+ Rewrite_Object_Declaration_As_Renaming (Par, New_N);
+
-- Otherwise rewrite the case expression itself
else
Append_To (Acts, Case_Stmt);
if Is_Copy_Type (Typ) then
- Rewrite (N,
+ New_N :=
Make_Expression_With_Actions (Loc,
Expression => New_Occurrence_Of (Target, Loc),
- Actions => Acts));
+ Actions => Acts);
else
Insert_Actions (N, Acts);
- Rewrite (N,
+ New_N :=
Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Target, Loc)));
+ Prefix => New_Occurrence_Of (Target, Loc));
end if;
+ Rewrite (N, New_N);
Analyze_And_Resolve (N, Typ);
end if;
end Expand_N_Case_Expression;
@@ -5488,11 +5590,44 @@ package body Exp_Ch4 is
-- actions in order to create a temporary to capture the level of the
-- expression in each branch.
+ function Is_Copy_Type (Typ : Entity_Id) return Boolean;
+ -- Return True if we can copy objects of this type when expanding an if
+ -- expression.
+
+ function Is_Optimizable_Declaration (N : Node_Id) return Boolean;
+ -- Return True if N is an object declaration that can be optimized
+
function OK_For_Single_Subtype (T1, T2 : Entity_Id) return Boolean;
-- Return true if it is acceptable to use a single subtype for two
-- dependent expressions of subtype T1 and T2 respectively, which are
-- unidimensional arrays whose index bounds are known at compile time.
+ ------------------
+ -- Is_Copy_Type --
+ ------------------
+
+ function Is_Copy_Type (Typ : Entity_Id) return Boolean is
+ Utyp : constant Entity_Id := Underlying_Type (Typ);
+
+ begin
+ return Is_Definite_Subtype (Utyp)
+ and then not Is_By_Reference_Type (Utyp);
+ end Is_Copy_Type;
+
+ --------------------------------
+ -- Is_Optimizable_Declaration --
+ --------------------------------
+
+ function Is_Optimizable_Declaration (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Object_Declaration
+ and then not (Is_Entity_Name (Object_Definition (N))
+ and then Is_Class_Wide_Type
+ (Entity (Object_Definition (N))))
+ and then not Is_Return_Object (Defining_Identifier (N))
+ and then not Is_Copy_Type (Typ);
+ end Is_Optimizable_Declaration;
+
---------------------------
-- OK_For_Single_Subtype --
---------------------------
@@ -5526,7 +5661,7 @@ package body Exp_Ch4 is
-- a safe assignment statement, expand into
-- if cond then
- -- lhs := then-expr
+ -- lhs := then-expr;
-- else
-- lhs := else-expr;
-- end if;
@@ -5539,7 +5674,7 @@ package body Exp_Ch4 is
-- a simple return statement, expand into
-- if cond then
- -- return then-expr
+ -- return then-expr;
-- else
-- return else-expr;
-- end if;
@@ -5547,6 +5682,23 @@ package body Exp_Ch4 is
-- This makes the expansion much easier when expressions are calls to
-- build-in-place functions.
+ Optimize_Object_Decl : Boolean := False;
+ -- Small optimization: when the if expression appears in the context of
+ -- an object declaration of a type not Is_Copy_Type, expand into
+
+ -- if cond then
+ -- then-obj : typ := then_expr;
+ -- target := then-obj'Unrestricted_Access;
+ -- else
+ -- else-obj : typ := else-expr;
+ -- target := else-obj'Unrestricted_Access;
+ -- end if;
+ --
+ -- obj : typ renames target.all;
+
+ -- This makes the expansion much easier when expressions are calls to
+ -- build-in-place functions.
+
-- Start of processing for Expand_N_If_Expression
begin
@@ -5560,7 +5712,9 @@ package body Exp_Ch4 is
declare
Uncond_Par : constant Node_Id := Unconditional_Parent (N);
begin
- if Nkind (Uncond_Par) = N_Simple_Return_Statement then
+ if Nkind (Uncond_Par) = N_Simple_Return_Statement
+ or else Is_Optimizable_Declaration (Uncond_Par)
+ then
Delay_Conditional_Expressions_Between (N, Uncond_Par);
end if;
end;
@@ -5578,6 +5732,9 @@ package body Exp_Ch4 is
elsif Nkind (Par) = N_Simple_Return_Statement then
Optimize_Return_Stmt := True;
+ elsif Is_Optimizable_Declaration (Par) then
+ Optimize_Object_Decl := True;
+
else
return;
end if;
@@ -5685,6 +5842,8 @@ package body Exp_Ch4 is
Condition => Relocate_Node (Cond),
Then_Statements => New_List (New_Then),
Else_Statements => New_List (New_Else));
+ Decl := Empty;
+ New_N := Empty;
-- Preserve the original context for which the if statement is
-- being generated. This is needed by the finalization machinery
@@ -5732,6 +5891,8 @@ package body Exp_Ch4 is
Else_Statements => New_List (
Make_Simple_Return_Statement (Sloc (New_Else),
Expression => New_Else)));
+ Decl := Empty;
+ New_N := Empty;
-- Preserve the original context for which the if statement is
-- being generated. This is needed by the finalization machinery
@@ -5740,6 +5901,99 @@ package body Exp_Ch4 is
Set_From_Conditional_Expression (If_Stmt);
+ elsif Optimize_Object_Decl then
+ -- When the "then" or "else" expressions involve controlled function
+ -- calls, generated temporaries are chained on the corresponding list
+ -- of actions. These temporaries need to be finalized after the if
+ -- expression is evaluated.
+
+ Process_Transients_In_Expression (N, Then_Actions (N));
+ Process_Transients_In_Expression (N, Else_Actions (N));
+
+ declare
+ Par_Obj : constant Entity_Id := Defining_Identifier (Par);
+ Then_Obj : constant Entity_Id := Make_Temporary (Loc, 'C', Thenx);
+ Else_Obj : constant Entity_Id := Make_Temporary (Loc, 'C', Elsex);
+ Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
+ Target : constant Entity_Id := Make_Temporary (Loc, 'C', N);
+
+ begin
+ Insert_Conditional_Object_Declaration (Then_Obj, Thenx, Par);
+ Insert_Conditional_Object_Declaration (Else_Obj, Elsex, Par);
+
+ -- Generate:
+ -- type Ptr_Typ is not null access all [constant] Typ;
+
+ Insert_Action (Par,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Null_Exclusion_Present => True,
+ Subtype_Indication => New_Occurrence_Of (Typ, Loc),
+ Constant_Present => Constant_Present (Par))));
+
+ -- Generate:
+ -- Target : Ptr_Typ;
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Target,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
+ Set_No_Initialization (Decl);
+ Insert_Action (Par, Decl);
+
+ -- Generate:
+ -- if Cond then
+ -- Target := <Then_Obj>'Unrestricted_Access;
+ -- else
+ -- Target := <Else_Obj>'Unrestricted_Access;
+ -- end if;
+
+ If_Stmt :=
+ Make_Implicit_If_Statement (N,
+ Condition => Relocate_Node (Cond),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Thenx),
+ Name => New_Occurrence_Of (Target, Sloc (Thenx)),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Then_Obj, Loc),
+ Attribute_Name => Name_Unrestricted_Access))),
+
+ Else_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Elsex),
+ Name => New_Occurrence_Of (Target, Sloc (Elsex)),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Else_Obj, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+
+ -- Preserve the original context for which the if statement is
+ -- being generated. This is needed by the finalization machinery
+ -- to prevent the premature finalization of controlled objects
+ -- found within the if statement.
+
+ Set_From_Conditional_Expression (If_Stmt);
+
+ New_N :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Target, Loc));
+
+ -- The renaming is not analyzed so complete the decoration of the
+ -- object and set the type of the name directly.
+
+ if Constant_Present (Par) then
+ Mutate_Ekind (Par_Obj, E_Constant);
+ Set_Is_True_Constant (Par_Obj);
+ else
+ Mutate_Ekind (Par_Obj, E_Variable);
+ end if;
+
+ Set_Etype (New_N, Etype (Par_Obj));
+ end;
+
-- If the result is a unidimensional unconstrained array but the two
-- dependent expressions have constrained subtypes with known bounds,
-- then we expand as follows:
@@ -5984,8 +6238,8 @@ package body Exp_Ch4 is
High_Bound => Build_New_Bound (Then_Hi, Else_Hi, Slice_Hi)));
end;
- -- If the type is by reference or else not definite, then we expand as
- -- follows to avoid the possibility of improper copying.
+ -- If the type cannot be copied, then we expand as follows to avoid the
+ -- possibility of improper copying.
-- type Ptr_Typ is not null access all Typ;
-- Target : Ptr;
@@ -5999,9 +6253,7 @@ package body Exp_Ch4 is
-- and replace the if expression by a reference to Target.all.
- elsif Is_By_Reference_Type (Typ)
- or else not Is_Definite_Subtype (Typ)
- then
+ elsif not Is_Copy_Type (Typ) then
-- When the "then" or "else" expressions involve controlled function
-- calls, generated temporaries are chained on the corresponding list
-- of actions. These temporaries need to be finalized after the if
@@ -6240,6 +6492,10 @@ package body Exp_Ch4 is
Rewrite (Par, If_Stmt);
Analyze (Par);
+ elsif Optimize_Object_Decl then
+ Insert_Action (Par, If_Stmt);
+ Rewrite_Object_Declaration_As_Renaming (Par, New_N);
+
-- Otherwise rewrite the if expression itself
else
@@ -12931,6 +13187,70 @@ package body Exp_Ch4 is
end if;
end Get_Size_For_Range;
+ -------------------------------------------
+ -- Insert_Conditional_Object_Declaration --
+ -------------------------------------------
+
+ procedure Insert_Conditional_Object_Declaration
+ (Obj_Id : Entity_Id;
+ Expr : Node_Id;
+ Decl : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Obj_Decl : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Obj_Id,
+ Aliased_Present => Aliased_Present (Decl),
+ Constant_Present => Constant_Present (Decl),
+ Object_Definition => New_Copy_Tree (Object_Definition (Decl)),
+ Expression => Relocate_Node (Expr));
+
+ Master_Node_Decl : Node_Id;
+ Master_Node_Id : Entity_Id;
+
+ begin
+ -- 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 (Obj_Decl)) then
+ Unanalyze_Delayed_Conditional_Expression (Expression (Obj_Decl));
+ end if;
+
+ Insert_Action (Expr, Obj_Decl);
+
+ -- If the object needs finalization, we need to insert its Master_Node
+ -- manually because 1) the machinery in Exp_Ch7 will not pick it since
+ -- it will be declared in the arm of a conditional statement and 2) we
+ -- cannot invoke Process_Transients_In_Expression on it since it is not
+ -- a transient object (it has the lifetime of the original object).
+
+ if Nkind (Obj_Decl) = N_Object_Declaration
+ and then Needs_Finalization (Base_Type (Etype (Obj_Id)))
+ then
+ Master_Node_Id := Make_Temporary (Loc, 'N');
+ Master_Node_Decl :=
+ Make_Master_Node_Declaration (Loc, Master_Node_Id, Obj_Id);
+
+ -- The master is the innermost enclosing non-transient construct
+
+ Insert_Action (Find_Hook_Context (Expr), Master_Node_Decl);
+
+ -- Propagate the relaxed finalization semantics
+
+ Set_Is_Independent
+ (Master_Node_Id,
+ Has_Relaxed_Finalization (Base_Type (Etype (Obj_Id))));
+
+ -- Generate the attachment of the object to the Master_Node
+
+ Attach_Object_To_Master_Node (Obj_Decl, Master_Node_Id);
+
+ -- Mark the transient object to avoid double finalization
+
+ Set_Is_Finalized_Transient (Obj_Id);
+ end if;
+ end Insert_Conditional_Object_Declaration;
+
-------------------------------
-- Insert_Dereference_Action --
-------------------------------
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 39cc9ab0c4fa..ef5faa1e34e3 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -5359,7 +5359,8 @@ package body Exp_Ch6 is
procedure Expand_Ctrl_Function_Call (N : Node_Id; Use_Sec_Stack : Boolean)
is
- Par : constant Node_Id := Parent (N);
+ Par : constant Node_Id := Parent (N);
+ Uncond_Par : constant Node_Id := Unconditional_Parent (N);
begin
-- Optimization: if the returned value is returned again, then no need
@@ -5368,7 +5369,7 @@ package body Exp_Ch6 is
-- Note that simple return statements are distributed into conditional
-- expressions but we may be invoked before this distribution is done.
- if Nkind (Unconditional_Parent (N)) = N_Simple_Return_Statement then
+ if Nkind (Uncond_Par) = N_Simple_Return_Statement then
return;
end if;
@@ -5381,8 +5382,15 @@ package body Exp_Ch6 is
if Nkind (Par) in N_Object_Declaration | N_Delta_Aggregate
and then Expression (Par) = N
- and then not Use_Sec_Stack
then
+ if not Use_Sec_Stack then
+ return;
+ end if;
+
+ -- Note that object declarations are also distributed into conditional
+ -- expressions but we may be invoked before this distribution is done.
+
+ elsif Nkind (Uncond_Par) = N_Object_Declaration then
return;
end if;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 017f16fa012c..171ad4ef3952 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -2546,7 +2546,8 @@ package body Exp_Ch7 is
elsif Ekind (Obj_Id) = E_Variable
and then Is_RTE (Obj_Typ, RE_Master_Node)
then
- Processing_Actions (Decl);
+ Processing_Actions
+ (Decl, Strict => not Is_Independent (Obj_Id));
-- The object is of the form:
-- Obj : [constant] Typ [:= Expr];
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 27d823333733..e449d45cdfdb 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -36,6 +36,7 @@ with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
+with Exp_Dbug; use Exp_Dbug;
with Freeze; use Freeze;
with Ghost; use Ghost;
with Inline; use Inline;
@@ -13556,6 +13557,46 @@ package body Exp_Util is
return False;
end Requires_Cleanup_Actions;
+ --------------------------------------------
+ -- Rewrite_Object_Declaration_As_Renaming --
+ --------------------------------------------
+
+ procedure Rewrite_Object_Declaration_As_Renaming (N, Nam : Node_Id) is
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ Rewrite (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Mark => New_Occurrence_Of (Etype (Def_Id), Loc),
+ Name => Nam));
+
+ -- Keep original aspects
+
+ Move_Aspects (Original_Node (N), N);
+
+ -- We do not analyze this renaming declaration, because all its
+ -- components have already been analyzed, and if we were to go
+ -- ahead and analyze it, we would in effect be trying to generate
+ -- another declaration of X, which won't do.
+
+ Set_Renamed_Object (Def_Id, Nam);
+ Set_Analyzed (N);
+
+ -- We do need to deal with debug issues for this renaming
+
+ -- First, if entity comes from source, then mark it as needing
+ -- debug information, even though it is defined by a generated
+ -- renaming that does not come from source.
+
+ Set_Debug_Info_Defining_Id (N);
+
+ -- Now call the routine to generate debug info for the renaming
+
+ Insert_Action (N, Debug_Renaming_Declaration (N));
+ end Rewrite_Object_Declaration_As_Renaming;
+
------------------------------------
-- Safe_Unchecked_Type_Conversion --
------------------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index fc70ac5f0126..81e51afcd6cb 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -1243,6 +1243,9 @@ package Exp_Util is
-- These cases require special actions on scope exit. Lib_Level is True if
-- the construct is at library level, and False otherwise.
+ procedure Rewrite_Object_Declaration_As_Renaming (N, Nam : Node_Id);
+ -- Rewrite object declaration N as an object renaming declaration of Nam
+
function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean;
-- Given the node for an N_Unchecked_Type_Conversion, return True if this
-- is an unchecked conversion that Gigi can handle directly. Otherwise
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 76ae53badd1d..eb53d59032c6 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -4689,11 +4689,22 @@ package body Sem_Ch3 is
if Back_End_Inlining
and then Expander_Active
and then Nkind (E) = N_Function_Call
- and then Nkind (Name (E)) in N_Has_Entity
+ and then Is_Entity_Name (Name (E))
and then Is_Inlined (Entity (Name (E)))
and then not Is_Constrained (Etype (E))
- and then Analyzed (N)
and then No (Expression (N))
+ and then Analyzed (N)
+ then
+ goto Leave;
+ end if;
+
+ -- No further action needed if E is a conditional expression and N
+ -- has been replaced by a renaming declaration during its expansion
+ -- (see Expand_N_Case_Expression and Expand_N_If_Expression).
+
+ if Expander_Active
+ and then Nkind (E) in N_Case_Expression | N_If_Expression
+ and then Nkind (N) = N_Object_Renaming_Declaration
then
goto Leave;
end if;
