ada: Further optimize interface objects initialized with function calls

This further optimizes the usual case of (class-wide) interface objects that
are initialized with calls to functions whose result type is the type of the
objects (this is not necessary as any result type implementing the interface
would do) by avoiding a back-and-forth displacement of the objects' address.

This exposed a latent issue whereby the displacement was missing in the case
of a simple return statement whose expression is a call to a function whose
result type is a specific tagged type that needs finalization.

And, in order to avoid pessimizing the expanded code, this in turn required
avoiding to create temporaries for allocators by calling Remove_Side_Effects
up front, in the common cases when they are not necessary.

gcc/ada/

	* exp_ch3.adb (Expand_N_Object_Declaration): Do not generate a back-
	and-forth displacement of the object's address when using a renaming
	for an interface object with an expression of the same type.
	* exp_ch4.adb (Expand_Allocator_Expression): Do not remove the side
	effects of the expression up front for the simple allocators. Do not
	call the Adjust primitive if the expression is a function call.
	* exp_ch6.adb (Expand_Ctrl_Function_Call): Do not expand the call
	unnecessarily for a special return object.
	(Expand_Simple_Function_Return): Restore the displacement of the
	return object's address in the case where the expression is the call
	to a function whose result type is a type that needs finalization.
	* exp_util.adb (Expand_Subtype_From_Expr): Do not remove the side
	effects of the expression before calling Make_Subtype_From_Expr.
	(Make_CW_Equivalent_Type): If the expression has the tag of its type
	and this type has a uniform size, use 'Object_Size of this type in
	lieu of 'Size of the expression to compute the expression's size.

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 84594ed106b4c53bc2eeb15bdddb1be52bae4e20..bbb53fc6e49f4ee829c8bd287e7d62d28dc45a98 100644 (file)
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -7589,6 +7589,13 @@ package body Exp_Ch3 is
                       Typ     => Base_Typ);
                end if;
 
+            --  Renaming an expression of the object's type is immediate
+
+            elsif Rewrite_As_Renaming
+              and then Base_Type (Etype (Expr_Q)) = Base_Type (Typ)
+            then
+               null;
+
             elsif Tagged_Type_Expansion then
                declare
                   Iface : constant Entity_Id := Root_Type (Typ);

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index d3a4f5748660f23a21f705ba6d973f4565dcf11c..31823eaeca7e0b8d394abd8a6b4baecc61a8d6e0 100644 (file)
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -698,11 +698,14 @@ package body Exp_Ch4 is
          --  recursion and inappropriate call to Initialize.
 
          --  We don't want to remove side effects when the expression must be
-         --  built in place. In the case of a build-in-place function call,
-         --  that could lead to a duplication of the call, which was already
-         --  substituted for the allocator.
+         --  built in place and we don't need it when there is no storage pool
+         --  or this is a return/secondary stack allocation.
 
-         if not Aggr_In_Place then
+         if not Aggr_In_Place
+           and then Present (Storage_Pool (N))
+           and then not Is_RTE (Storage_Pool (N), RE_RS_Pool)
+           and then not Is_RTE (Storage_Pool (N), RE_SS_Pool)
+         then
             Remove_Side_Effects (Exp);
          end if;
 
@@ -747,7 +750,7 @@ package body Exp_Ch4 is
 
          --  Processing for allocators returning non-interface types
 
-         if not Is_Interface (Directly_Designated_Type (PtrT)) then
+         if not Is_Interface (DesigT) then
             if Aggr_In_Place then
                Temp_Decl :=
                  Make_Object_Declaration (Loc,
@@ -960,8 +963,9 @@ package body Exp_Ch4 is
 
          if Needs_Finalization (DesigT)
            and then Needs_Finalization (T)
-           and then not Aggr_In_Place
            and then not Is_Limited_View (T)
+           and then not Aggr_In_Place
+           and then Nkind (Exp) /= N_Function_Call
            and then not For_Special_Return_Object (N)
          then
             --  An unchecked conversion is needed in the classwide case because
@@ -993,7 +997,7 @@ package body Exp_Ch4 is
          --  component containing the secondary dispatch table of the interface
          --  type.
 
-         if Is_Interface (Directly_Designated_Type (PtrT)) then
+         if Is_Interface (DesigT) then
             Displace_Allocator_Pointer (N);
          end if;
 

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 503fdc1ee6b6da1e5bf302d53ff6c36a265bad3b..7abf25e3859a8b6992f21fa0bf3f63284002df7b 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -5133,14 +5133,11 @@ package body Exp_Ch6 is
 
       --  Another optimization: if the returned value is used to initialize an
       --  object, then no need to copy/readjust/finalize, we can initialize it
-      --  in place. However, if the call returns on the secondary stack or this
-      --  is a special return object, then we need the expansion because we'll
-      --  be renaming the temporary as the (permanent) object.
+      --  in place. However, if the call returns on the secondary stack, then
+      --  we need the expansion because we'll be renaming the temporary as the
+      --  (permanent) object.
 
-      if Nkind (Par) = N_Object_Declaration
-        and then not Use_Sec_Stack
-        and then not Is_Special_Return_Object (Defining_Entity (Par))
-      then
+      if Nkind (Par) = N_Object_Declaration and then not Use_Sec_Stack then
          return;
       end if;
 
@@ -6745,7 +6742,7 @@ package body Exp_Ch6 is
             null;
 
          --  Optimize the case where the result is a function call that also
-         --  returns on the secondary stack. In this case the result is already
+         --  returns on the secondary stack; in this case the result is already
          --  on the secondary stack and no further processing is required.
 
          elsif Exp_Is_Function_Call
@@ -6781,13 +6778,14 @@ package body Exp_Ch6 is
          --  gigi is not able to properly allocate class-wide types.
 
          --  But optimize the case where the result is a function call that
-         --  also needs finalization. In this case the result can directly be
+         --  also needs finalization; in this case the result can directly be
          --  allocated on the secondary stack and no further processing is
-         --  required.
+         --  required, unless the returned object is an interface.
 
          elsif CW_Or_Needs_Finalization (Utyp)
-           and then not (Exp_Is_Function_Call
-                          and then Needs_Finalization (Exp_Typ))
+           and then (Is_Interface (R_Type)
+                      or else not (Exp_Is_Function_Call
+                                    and then Needs_Finalization (Exp_Typ)))
          then
             declare
                Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index cac0d84e453979ed033b9f6b2b3847bcb43308c6..f86b93819ac1e7eac57cc0cc4c9876b047ab6f6f 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -5820,7 +5820,6 @@ package body Exp_Util is
          --  discriminants.
 
          else
-            Remove_Side_Effects (Exp);
             Rewrite (Subtype_Indic,
               Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
          end if;
@@ -5885,7 +5884,6 @@ package body Exp_Util is
          end if;
 
       else
-         Remove_Side_Effects (Exp);
          Rewrite (Subtype_Indic,
            Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id));
       end if;
@@ -9496,12 +9494,13 @@ package body Exp_Util is
       Root_Utyp   : constant Entity_Id  := Underlying_Type (Root_Typ);
       List_Def    : constant List_Id    := Empty_List;
       Comp_List   : constant List_Id    := New_List;
+
       Equiv_Type  : Entity_Id;
       Range_Type  : Entity_Id;
       Str_Type    : Entity_Id;
       Constr_Root : Entity_Id;
+      Size_Attr   : Node_Id;
       Size_Expr   : Node_Id;
-      Size_Pref   : Node_Id;
 
       function Has_Tag_Of_Type (Exp : Node_Id) return Boolean;
       --  Return True if expression Exp of a tagged type is known to statically
@@ -9597,9 +9596,26 @@ package body Exp_Util is
       --  the _Size primitive operation.
 
       if Has_Tag_Of_Type (E) then
-         Size_Pref := Duplicate_Subexpr_No_Checks (E);
+         if not Has_Discriminants (Etype (E))
+           or else Is_Constrained (Etype (E))
+         then
+            Size_Attr :=
+              Make_Attribute_Reference (Loc,
+                Prefix => New_Occurrence_Of (Etype (E), Loc),
+                Attribute_Name => Name_Object_Size);
+
+         else
+            Size_Attr :=
+              Make_Attribute_Reference (Loc,
+                Prefix => Duplicate_Subexpr_No_Checks (E),
+                Attribute_Name => Name_Size);
+         end if;
+
       else
-         Size_Pref := OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E));
+         Size_Attr :=
+           Make_Attribute_Reference (Loc,
+             Prefix => OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
+             Attribute_Name => Name_Size);
       end if;
 
       if not Is_Interface (Root_Typ) then
@@ -9610,10 +9626,7 @@ package body Exp_Util is
 
          Size_Expr :=
            Make_Op_Subtract (Loc,
-             Left_Opnd =>
-               Make_Attribute_Reference (Loc,
-                 Prefix => Size_Pref,
-                 Attribute_Name => Name_Size),
+             Left_Opnd => Size_Attr,
              Right_Opnd =>
                Make_Attribute_Reference (Loc,
                  Prefix => New_Occurrence_Of (Constr_Root, Loc),
@@ -9625,10 +9638,7 @@ package body Exp_Util is
 
          Size_Expr :=
            Make_Op_Subtract (Loc,
-             Left_Opnd =>
-               Make_Attribute_Reference (Loc,
-                 Prefix => Size_Pref,
-                 Attribute_Name => Name_Size),
+             Left_Opnd => Size_Attr,
              Right_Opnd =>
                Make_Attribute_Reference (Loc,
                  Prefix => New_Occurrence_Of (RTE (RE_Tag), Loc),