* [COMMITTED] ada: Optimize class-wide objects initialized with function calls
@ 2023-01-05 14:40 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2023-01-05 14:40 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch3.adb | 54 +++++++++++++++------------
gcc/ada/exp_util.adb | 89 ++++++++++++++++++++++++++++++++++++++------
2 files changed, 108 insertions(+), 35 deletions(-)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index a3b62249c7d..23a910ecdba 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 74cd99cade2..9fbd6dfbd82 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)))))));
--
2.34.1
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-01-05 14:40 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-01-05 14:40 [COMMITTED] ada: Optimize class-wide objects initialized with function calls Marc Poulhiès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).