ada: Optimize class-wide objects initialized with function calls

This optimizes the implementation of class-wide objects initialized with
function calls in the non-interface case, by avoiding an unnecessary copy
operation and/or a dispatching call to the _Size primitive when possible.

gcc/ada/

	* exp_ch3.adb (Expand_N_Object_Declaration): New local variable
	Func_Id holding the function for a special return object.
	Use a direct renaming in the class-wide case when the initializing
	expression is a captured function call, except for a special return
	object when the two functions do not return on the same stack.
	Apply the accessibility check for class-wide special return objects.
	* exp_util.adb (Make_CW_Equivalent_Type) <Has_Tag_Of_Type>: New.
	Do not force a dispatching call to the primitive operation _Size if
	the expression is known to statically have the tag of its type.

2 files changed, 108 insertions, 35 deletions

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index a3b6224..23a910e 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6235,6 +6235,10 @@ package body Exp_Ch3 is
       --  and ultimately rewritten as a renaming, so initialization activities
       --  need to be deferred until after that is done.
 
+      Func_Id : constant Entity_Id :=
+       (if Special_Ret_Obj then Return_Applies_To (Scope (Def_Id)) else Empty);
+      --  The function if this is a special return object, otherwise Empty
+
       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,
@@ -6243,7 +6247,6 @@ package body Exp_Ch3 is
       function Build_Heap_Or_Pool_Allocator
         (Temp_Id    : Entity_Id;
          Temp_Typ   : Entity_Id;
-         Func_Id    : Entity_Id;
          Ret_Typ    : Entity_Id;
          Alloc_Expr : Node_Id) return Node_Id;
       --  Create the statements necessary to allocate a return object on the
@@ -6442,7 +6445,6 @@ package body Exp_Ch3 is
       function Build_Heap_Or_Pool_Allocator
         (Temp_Id    : Entity_Id;
          Temp_Typ   : Entity_Id;
-         Func_Id    : Entity_Id;
          Ret_Typ    : Entity_Id;
          Alloc_Expr : Node_Id) return Node_Id
       is
@@ -7103,8 +7105,6 @@ package body Exp_Ch3 is
       -------------------------------
 
       function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id is
-         Func_Id : constant Entity_Id := Return_Applies_To (Scope (Def_Id));
-
          Alloc : Node_Id;
 
       begin
@@ -7933,13 +7933,19 @@ package body Exp_Ch3 is
                 --  finalize it prematurely (see Expand_Simple_Function_Return
                 --  for the same test in the case of a simple return).
 
+                --  Moreover, in the case of a special return object, we also
+                --  need to make sure that the two functions return on the same
+                --  stack, otherwise we would create a dangling reference.
+
                 and then
                   ((not Is_Library_Level_Entity (Def_Id)
                      and then Is_Captured_Function_Call (Expr_Q)
-                     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))
+                     and then
+                       (not Special_Ret_Obj
+                         or else
+                          (Is_Related_To_Func_Return (Entity (Prefix (Expr_Q)))
+                            and then Needs_Secondary_Stack (Etype (Expr_Q)) =
+                                     Needs_Secondary_Stack (Etype (Func_Id)))))
 
                    --  If the initializing expression is a variable with the
                    --  flag OK_To_Rename set, then transform:
@@ -8148,8 +8154,6 @@ package body Exp_Ch3 is
 
       if Is_Build_In_Place_Return_Object (Def_Id) then
          declare
-            Func_Id : constant Entity_Id := Return_Applies_To (Scope (Def_Id));
-
             Init_Stmt       : Node_Id;
             Obj_Acc_Formal  : Entity_Id;
 
@@ -8441,7 +8445,6 @@ package body Exp_Ch3 is
                             Build_Heap_Or_Pool_Allocator
                               (Temp_Id    => Alloc_Obj_Id,
                                Temp_Typ   => Acc_Typ,
-                               Func_Id    => Func_Id,
                                Ret_Typ    => Desig_Typ,
                                Alloc_Expr => Heap_Allocator))),
 
@@ -8465,7 +8468,6 @@ package body Exp_Ch3 is
                             Build_Heap_Or_Pool_Allocator
                               (Temp_Id    => Alloc_Obj_Id,
                                Temp_Typ   => Acc_Typ,
-                               Func_Id    => Func_Id,
                                Ret_Typ    => Desig_Typ,
                                Alloc_Expr => Pool_Allocator)))),
 
@@ -8586,11 +8588,8 @@ package body Exp_Ch3 is
       --  and that the tag is assigned in the case of any return object.
 
       elsif Rewrite_As_Renaming then
-         if Is_Secondary_Stack_Return_Object (Def_Id) then
+         if Special_Ret_Obj then
             declare
-               Func_Id  : constant Entity_Id  :=
-                 Return_Applies_To (Scope (Def_Id));
-
                Desig_Typ : constant Entity_Id :=
                  (if Ekind (Typ) = E_Array_Subtype
                   then Etype (Func_Id) else Typ);
@@ -8603,11 +8602,23 @@ package body Exp_Ch3 is
                   Set_Etype (Def_Id, Desig_Typ);
                   Set_Actual_Subtype (Def_Id, Typ);
                end if;
-            end;
-         end if;
 
-         if Special_Ret_Obj and then Present (Tag_Assign) then
-            Insert_Action_After (Init_After, Tag_Assign);
+               if Present (Tag_Assign) then
+                  Insert_Action_After (Init_After, Tag_Assign);
+               end if;
+
+               --  Ada 2005 (AI95-344): If the result type is class-wide,
+               --  insert a check that the level of the return expression's
+               --  underlying type is not deeper than the level of the master
+               --  enclosing the function.
+
+               --  AI12-043: The check is made immediately after the return
+               --  object is created.
+
+               if Is_Class_Wide_Type (Etype (Func_Id)) then
+                  Apply_CW_Accessibility_Check (Expr_Q, Func_Id);
+               end if;
+            end;
          end if;
 
       --  If this is the return object of a function returning on the secondary
@@ -8628,9 +8639,6 @@ package body Exp_Ch3 is
 
       elsif Is_Secondary_Stack_Return_Object (Def_Id) then
          declare
-            Func_Id  : constant Entity_Id  :=
-              Return_Applies_To (Scope (Def_Id));
-
             Desig_Typ : constant Entity_Id :=
               (if Ekind (Typ) = E_Array_Subtype
                then Etype (Func_Id) else Typ);
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 74cd99c..9fbd6df 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -9669,7 +9669,7 @@ package body Exp_Util is
 
    --   type Equiv_T is record
    --     _parent : T (List of discriminant constraints taken from Exp);
-   --     Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
+   --     Cnn : Storage_Array (1 .. (Exp'size - Typ'object_size)/Storage_Unit);
    --   end Equiv_T;
    --
    --  Note that this type does not guarantee same alignment as all derived
@@ -9693,7 +9693,63 @@ package body Exp_Util is
       Range_Type  : Entity_Id;
       Str_Type    : Entity_Id;
       Constr_Root : Entity_Id;
-      Sizexpr     : 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
+      --  have the tag of this tagged type as specified by RM 3.9(19-25).
+
+      ---------------------
+      -- Has_Tag_Of_Type --
+      ---------------------
+
+      function Has_Tag_Of_Type (Exp : Node_Id) return Boolean is
+         Typ : constant Entity_Id := Etype (Exp);
+
+      begin
+         pragma Assert (Is_Tagged_Type (Typ));
+
+         --  The tag of an object of a class-wide type is that of its
+         --  initialization expression.
+
+         if Is_Class_Wide_Type (Typ) then
+            return False;
+         end if;
+
+         --  The tag of a stand-alone object of a specific tagged type T
+         --  identifies T.
+
+         if Is_Entity_Name (Exp)
+           and then Ekind (Entity (Exp)) in Constant_Or_Variable_Kind
+         then
+            return True;
+
+         else
+            case Nkind (E) is
+               --  The tag of a component or an aggregate of a specific tagged
+               --  type T identifies T.
+
+               when N_Indexed_Component
+                 |  N_Selected_Component
+                 |  N_Aggregate
+               =>
+                  return True;
+
+               --  The tag of the result returned by a function whose result
+               --  type is a specific tagged type T identifies T.
+
+               when N_Function_Call =>
+                  return True;
+
+               when N_Explicit_Dereference =>
+                  return Is_Captured_Function_Call (Exp);
+
+               when others =>
+                  return False;
+            end case;
+         end if;
+      end Has_Tag_Of_Type;
 
    begin
       --  If the root type is already constrained, there are no discriminants
@@ -9728,18 +9784,28 @@ package body Exp_Util is
 
       Range_Type := Make_Temporary (Loc, 'G');
 
+      --  If the expression is known to have the tag of its type, then we can
+      --  use it directly for the prefix of the Size attribute; otherwise we
+      --  need to convert it first to the class-wide type to force a call to
+      --  the _Size primitive operation.
+
+      if Has_Tag_Of_Type (E) then
+         Size_Pref := Duplicate_Subexpr_No_Checks (E);
+      else
+         Size_Pref := OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E));
+      end if;
+
       if not Is_Interface (Root_Typ) then
 
          --  subtype rg__xx is
-         --    Storage_Offset range 1 .. (Expr'size - typ'object_size)
+         --    Storage_Offset range 1 .. (Exp'size - Typ'object_size)
          --                                / Storage_Unit
 
-         Sizexpr :=
+         Size_Expr :=
            Make_Op_Subtract (Loc,
              Left_Opnd =>
                Make_Attribute_Reference (Loc,
-                 Prefix =>
-                   OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
+                 Prefix => Size_Pref,
                  Attribute_Name => Name_Size),
              Right_Opnd =>
                Make_Attribute_Reference (Loc,
@@ -9747,15 +9813,14 @@ package body Exp_Util is
                  Attribute_Name => Name_Object_Size));
       else
          --  subtype rg__xx is
-         --    Storage_Offset range 1 .. (Expr'size - Ada.Tags.Tag'object_size)
+         --    Storage_Offset range 1 .. (Exp'size - Ada.Tags.Tag'object_size)
          --                                / Storage_Unit
 
-         Sizexpr :=
+         Size_Expr :=
            Make_Op_Subtract (Loc,
              Left_Opnd =>
                Make_Attribute_Reference (Loc,
-                 Prefix =>
-                   OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
+                 Prefix => Size_Pref,
                  Attribute_Name => Name_Size),
              Right_Opnd =>
                Make_Attribute_Reference (Loc,
@@ -9763,7 +9828,7 @@ package body Exp_Util is
                  Attribute_Name => Name_Object_Size));
       end if;
 
-      Set_Paren_Count (Sizexpr, 1);
+      Set_Paren_Count (Size_Expr, 1);
 
       Append_To (List_Def,
         Make_Subtype_Declaration (Loc,
@@ -9777,7 +9842,7 @@ package body Exp_Util is
                     Low_Bound => Make_Integer_Literal (Loc, 1),
                     High_Bound =>
                       Make_Op_Divide (Loc,
-                        Left_Opnd => Sizexpr,
+                        Left_Opnd => Size_Expr,
                         Right_Opnd => Make_Integer_Literal (Loc,
                             Intval => System_Storage_Unit)))))));