From: Eric Botcazou <ebotca...@adacore.com>
Using an unconstrained allocation is less efficient in the general case.
gcc/ada/
* exp_ch3.adb (Expand_N_Object_Declaration): New local variable used
throughout instead of testing Is_Special_Return_Object every time.
Do not rename an OK_To_Rename object for a special return object.
* exp_ch4.adb (Expand_Concatenate): Revert to constrained allocation
if the result is allocated on the secondary stack.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch3.adb | 29 +++++++++-------
gcc/ada/exp_ch4.adb | 82 +++++++++++++++++++--------------------------
2 files changed, 50 insertions(+), 61 deletions(-)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 7dbf82671aa..a76acf34d66 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6230,6 +6230,11 @@ package body Exp_Ch3 is
Base_Typ : constant Entity_Id := Base_Type (Typ);
Next_N : constant Node_Id := Next (N);
+ Special_Ret_Obj : constant Boolean := Is_Special_Return_Object (Def_Id);
+ -- If this is a special return object, it will be allocated differently
+ -- and ultimately rewritten as a renaming, so initialization activities
+ -- need to be deferred until after that is done.
+
function Build_Equivalent_Aggregate return Boolean;
-- If the object has a constrained discriminated type and no initial
-- value, it may be possible to build an equivalent aggregate instead,
@@ -7343,7 +7348,7 @@ package body Exp_Ch3 is
end if;
end if;
- if not Is_Special_Return_Object (Def_Id) then
+ if not Special_Ret_Obj then
Default_Initialize_Object (Init_After);
end if;
@@ -7403,7 +7408,7 @@ package body Exp_Ch3 is
Expander_Mode_Restore;
end if;
- if not Is_Special_Return_Object (Def_Id) then
+ if not Special_Ret_Obj then
Convert_Aggr_In_Object_Decl (N);
end if;
@@ -7479,7 +7484,7 @@ package body Exp_Ch3 is
-- case, the expansion of the return statement will take care of
-- creating the object (via allocator) and initializing it.
- if Is_Special_Return_Object (Def_Id) then
+ if Special_Ret_Obj then
-- If the type needs finalization and is not inherently
-- limited, then the target is adjusted after the copy
@@ -7791,7 +7796,7 @@ package body Exp_Ch3 is
if Present (Tag_Assign) then
if Present (Following_Address_Clause (N)) then
Ensure_Freeze_Node (Def_Id);
- elsif not Is_Special_Return_Object (Def_Id) then
+ elsif not Special_Ret_Obj then
Insert_Action_After (Init_After, Tag_Assign);
end if;
@@ -7931,7 +7936,7 @@ package body Exp_Ch3 is
and then
((not Is_Library_Level_Entity (Def_Id)
and then Is_Captured_Function_Call (Expr_Q)
- and then (not Is_Special_Return_Object (Def_Id)
+ and then (not Special_Ret_Obj
or else Is_Related_To_Func_Return
(Entity (Prefix (Expr_Q))))
and then not Is_Class_Wide_Type (Typ))
@@ -7945,12 +7950,14 @@ package body Exp_Ch3 is
-- Obj : Typ renames Expr;
- or else OK_To_Rename_Ref (Expr_Q)
+ or else (OK_To_Rename_Ref (Expr_Q)
+ and then not Special_Ret_Obj)
-- Likewise if it is a slice of such a variable
or else (Nkind (Expr_Q) = N_Slice
- and then OK_To_Rename_Ref (Prefix (Expr_Q))));
+ and then OK_To_Rename_Ref (Prefix (Expr_Q))
+ and then not Special_Ret_Obj));
-- If the type needs finalization and is not inherently limited,
-- then the target is adjusted after the copy and attached to the
@@ -7971,9 +7978,7 @@ package body Exp_Ch3 is
Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Typ);
- if Present (Adj_Call)
- and then not Is_Special_Return_Object (Def_Id)
- then
+ if Present (Adj_Call) and then not Special_Ret_Obj then
Insert_Action_After (Init_After, Adj_Call);
end if;
end if;
@@ -8601,9 +8606,7 @@ package body Exp_Ch3 is
end;
end if;
- if Is_Special_Return_Object (Def_Id)
- and then Present (Tag_Assign)
- then
+ if Special_Ret_Obj and then Present (Tag_Assign) then
Insert_Action_After (Init_After, Tag_Assign);
end if;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 148b160b792..d9103b3387b 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -2728,7 +2728,6 @@ package body Exp_Ch4 is
Len : Unat;
J : Nat;
Clen : Node_Id;
- Decl : Node_Id;
Set : Boolean;
-- Start of processing for Expand_Concatenate
@@ -3255,32 +3254,10 @@ package body Exp_Ch4 is
Set_Is_Internal (Ent);
Set_Debug_Info_Needed (Ent);
- -- If the bound is statically known to be out of range, we do not want
- -- to abort, we want a warning and a constraint error at run time. Note
- -- that we have arranged that the result will not be treated as a static
- -- constant, so we won't get an illegality during the insertion. We also
- -- enable all checks (in particular range checks) in case the bounds of
- -- Subtyp_Ind are out of range.
-
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Ent,
- Object_Definition => Subtyp_Ind);
- Insert_Action (Cnode, Decl);
-
- -- If the result of the concatenation appears as the initializing
- -- expression of an object declaration, we can just rename the
- -- result, rather than copying it.
-
- Set_OK_To_Rename (Ent);
-
-- If we are concatenating strings and the current scope already uses
-- the secondary stack, allocate the result also on the secondary stack
-- to avoid putting too much pressure on the primary stack.
- -- We use an unconstrained allocation, i.e. we also allocate the bounds,
- -- so that the result can be renamed in all contexts.
-
-- Don't do this if -gnatd.h is set, as this will break the wrapping of
-- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat.
@@ -3291,33 +3268,32 @@ package body Exp_Ch4 is
then
-- Generate:
-- subtype Axx is String (<low-bound> .. <high-bound>)
- -- type Ayy is access String;
+ -- type Ayy is access Axx;
-- Rxx : Ayy := new <Axx> [storage_pool = ss_pool];
- -- Sxx : String renames Rxx.all;
+ -- Sxx : Axx renames Rxx.all;
declare
ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
- Alloc : Node_Id;
- Deref : Node_Id;
- Temp : Entity_Id;
+ Alloc : Node_Id;
+ Temp : Entity_Id;
begin
- Insert_Action (Decl,
+ Insert_Action (Cnode,
Make_Subtype_Declaration (Loc,
Defining_Identifier => ConstrT,
Subtype_Indication => Subtyp_Ind),
Suppress => All_Checks);
- Freeze_Itype (ConstrT, Decl);
+ Freeze_Itype (ConstrT, Cnode);
- Insert_Action (Decl,
+ Insert_Action (Cnode,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
- Subtype_Indication => New_Occurrence_Of (Atyp, Loc))),
+ Subtype_Indication => New_Occurrence_Of (ConstrT, Loc))),
Suppress => All_Checks);
Mutate_Ekind (Acc_Typ, E_Access_Type);
@@ -3335,33 +3311,43 @@ package body Exp_Ch4 is
Set_No_Initialization (Alloc);
Temp := Make_Temporary (Loc, 'R', Alloc);
- Insert_Action (Decl,
+ Insert_Action (Cnode,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (Acc_Typ, Loc),
Expression => Alloc),
Suppress => All_Checks);
- Deref :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Temp, Loc));
- Set_Etype (Deref, Atyp);
-
- Rewrite (Decl,
+ Insert_Action (Cnode,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Ent,
- Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
- Name => Deref));
-
- -- We do not analyze this renaming declaration because this would
- -- change the subtype of Ent back to a constrained string.
-
- Set_Etype (Ent, Atyp);
- Set_Renamed_Object (Ent, Deref);
- Set_Analyzed (Decl);
+ Subtype_Mark => New_Occurrence_Of (ConstrT, Loc),
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Temp, Loc))),
+ Suppress => All_Checks);
end;
+
+ else
+ -- If the bound is statically known to be out of range, we do not
+ -- want to abort, we want a warning and a runtime constraint error.
+ -- Note that we have arranged that the result will not be treated
+ -- as a static constant, so we won't get an illegality during this
+ -- insertion. We also enable checks (in particular range checks) in
+ -- case the bounds of Subtyp_Ind are out of range.
+
+ Insert_Action (Cnode,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ent,
+ Object_Definition => Subtyp_Ind));
end if;
+ -- If the result of the concatenation appears as the initializing
+ -- expression of an object declaration, we can just rename the
+ -- result, rather than copying it.
+
+ Set_OK_To_Rename (Ent);
+
-- Catch the static out of range case now
if Raises_Constraint_Error (High_Bound)
--
2.34.1
