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

Reply via email to