* [COMMITTED] ada: Optimize interface objects initialized with function calls
@ 2023-01-16 14:48 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2023-01-16 14:48 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This optimizes the implementation of (class-wide) interface objects that are
initialized with function calls, by avoiding an unnecessary copy operation.
This also removes useless access checks generated by the expansion of return
statements involving class-wide types.
gcc/ada/
* exp_ch3.adb (Expand_N_Object_Declaration): Factor out conditions
needed for an initializating expression that is a function call to
be renamable into the Is_Renamable_Function_Call predicate.
Use it to implement the renaming in the case of class-wide interface
objects. Remove an interface conversion on all paths, separate and
optimize the renaming path in the special expansion for interfaces.
(Is_Renamable_Function_Call): New predicate.
(Make_Allocator_For_Return): Put back an interface conversion.
* exp_ch6.adb (Apply_CW_Accessibility_Check): Remove useless access
checks on RE_Tag_Ptr.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch3.adb | 283 ++++++++++++++++++++++++++------------------
gcc/ada/exp_ch6.adb | 30 ++---
2 files changed, 187 insertions(+), 126 deletions(-)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index f107b7ed36c..536ae0c36e4 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6306,6 +6306,38 @@ package body Exp_Ch3 is
-- Generate all initialization actions for return object Def_Id. Any
-- new code is inserted after node After.
+ function Is_Renamable_Function_Call (Expr : Node_Id) return Boolean;
+ -- If we are not at library level and the object declaration originally
+ -- appears in the form:
+
+ -- Obj : Typ := Func (...);
+
+ -- and has been rewritten as the dereference of a captured reference
+ -- to the function result built either on the primary or the secondary
+ -- stack, then the declaration can be rewritten as the renaming of this
+ -- dereference:
+
+ -- type Ann is access all Typ;
+ -- Rnn : constant Axx := Func (...)'reference;
+ -- Obj : Typ renames Rnn.all;
+
+ -- This will avoid making an extra copy and, in the case where Typ needs
+ -- finalization, a pair of calls to the Adjust and Finalize primitives,
+ -- or Deep_Adjust and Deep_Finalize routines, depending on whether Typ
+ -- has components that themselves need finalization.
+
+ -- However, in the case of a special return object, we need to make sure
+ -- that the object Rnn is recognized by the Is_Related_To_Func_Return
+ -- predicate; otherwise, if it is of a type that needs finalization,
+ -- then Requires_Cleanup_Actions would return true because of this and
+ -- Build_Finalizer would finalize it prematurely because of this (see
+ -- also Expand_Simple_Function_Return for the same test in the case of
+ -- a simple return).
+
+ -- Finally, 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.
+
function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id;
-- Make an allocator for a return object initialized with Expr
@@ -7100,12 +7132,28 @@ package body Exp_Ch3 is
end if;
end Initialize_Return_Object;
+ --------------------------------
+ -- Is_Renamable_Function_Call --
+ --------------------------------
+
+ function Is_Renamable_Function_Call (Expr : Node_Id) return Boolean is
+ begin
+ return not Is_Library_Level_Entity (Def_Id)
+ and then Is_Captured_Function_Call (Expr)
+ and then (not Special_Ret_Obj
+ or else
+ (Is_Related_To_Func_Return (Entity (Prefix (Expr)))
+ and then Needs_Secondary_Stack (Etype (Expr)) =
+ Needs_Secondary_Stack (Etype (Func_Id))));
+ end Is_Renamable_Function_Call;
+
-------------------------------
-- Make_Allocator_For_Return --
-------------------------------
function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id is
- Alloc : Node_Id;
+ Alloc : Node_Id;
+ Alloc_Expr : Entity_Id;
begin
-- If the return object's declaration includes an expression and the
@@ -7131,6 +7179,18 @@ package body Exp_Ch3 is
Apply_CW_Accessibility_Check (Expr, Func_Id);
end if;
+ Alloc_Expr := New_Copy_Tree (Expr);
+
+ -- In the interface case, put back a conversion that we may have
+ -- remove earlier in the processing.
+
+ if Is_Interface (Typ)
+ and then Is_Interface (Etype (Alloc_Expr))
+ and then Typ /= Etype (Alloc_Expr)
+ then
+ Alloc_Expr := Convert_To (Typ, Alloc_Expr);
+ end if;
+
-- We always use the type of the expression for the qualified
-- expression, rather than the return object's type. We cannot
-- always use the return object's type because the expression
@@ -7141,8 +7201,8 @@ package body Exp_Ch3 is
Expression =>
Make_Qualified_Expression (Loc,
Subtype_Mark =>
- New_Occurrence_Of (Etype (Expr), Loc),
- Expression => New_Copy_Tree (Expr)));
+ New_Occurrence_Of (Etype (Alloc_Expr), Loc),
+ Expression => Alloc_Expr));
else
Alloc :=
@@ -7479,12 +7539,42 @@ package body Exp_Ch3 is
then
pragma Assert (Is_Class_Wide_Type (Typ));
+ -- If the original node of the expression was a conversion
+ -- to this specific class-wide interface type then restore
+ -- the original node because we must copy the object before
+ -- displacing the pointer to reference the secondary tag
+ -- component. This code must be kept synchronized with the
+ -- expansion done by routine Expand_Interface_Conversion
+
+ if not Comes_From_Source (Expr)
+ and then Nkind (Expr) = N_Explicit_Dereference
+ and then Nkind (Original_Node (Expr)) = N_Type_Conversion
+ and then Etype (Original_Node (Expr)) = Typ
+ then
+ Rewrite (Expr, Original_Node (Expression (N)));
+ end if;
+
+ -- Avoid expansion of redundant interface conversion
+
+ if Nkind (Expr) = N_Type_Conversion
+ and then Etype (Expr) = Typ
+ then
+ Expr_Q := Expression (Expr);
+ else
+ Expr_Q := Expr;
+ end if;
+
+ -- We may use a renaming if the initializing expression is a
+ -- captured function call that meets a few conditions.
+
+ Rewrite_As_Renaming := Is_Renamable_Function_Call (Expr_Q);
+
-- If the object is a special return object, then bypass special
-- treatment of class-wide interface initialization below. In this
- -- case, the expansion of the return statement will take care of
- -- creating the object (via allocator) and initializing it.
+ -- case, the expansion of the return object will take care of this
+ -- initialization via the expansion of the allocator.
- if Special_Ret_Obj then
+ if Special_Ret_Obj and then not Rewrite_As_Renaming then
-- If the type needs finalization and is not inherently
-- limited, then the target is adjusted after the copy
@@ -7511,45 +7601,25 @@ package body Exp_Ch3 is
Tag_Comp : Node_Id;
begin
- -- If the original node of the expression was a conversion
- -- to this specific class-wide interface type then restore
- -- the original node because we must copy the object before
- -- displacing the pointer to reference the secondary tag
- -- component. This code must be kept synchronized with the
- -- expansion done by routine Expand_Interface_Conversion
-
- if not Comes_From_Source (Expr)
- and then Nkind (Expr) = N_Explicit_Dereference
- and then Nkind (Original_Node (Expr)) = N_Type_Conversion
- and then Etype (Original_Node (Expr)) = Typ
- then
- Rewrite (Expr, Original_Node (Expression (N)));
+ Expr_Typ := Base_Type (Etype (Expr_Q));
+ if Is_Class_Wide_Type (Expr_Typ) then
+ Expr_Typ := Root_Type (Expr_Typ);
end if;
- -- Avoid expansion of redundant interface conversion
+ -- Rename limited objects since they cannot be copied
- if Is_Interface (Etype (Expr))
- and then Nkind (Expr) = N_Type_Conversion
- and then Etype (Expr) = Typ
- then
- Expr_Q := Expression (Expr);
- else
- Expr_Q := Expr;
+ if Is_Limited_Record (Expr_Typ) then
+ Rewrite_As_Renaming := True;
end if;
- Obj_Id := Make_Temporary (Loc, 'D', Expr_Q);
- Expr_Typ := Base_Type (Etype (Expr_Q));
-
- if Is_Class_Wide_Type (Expr_Typ) then
- Expr_Typ := Root_Type (Expr_Typ);
- end if;
+ Obj_Id := Make_Temporary (Loc, 'D', Expr_Q);
-- Replace
-- CW : I'Class := Obj;
-- by
- -- Tmp : Typ := Obj;
+ -- Dnn : Typ := Obj;
-- type Ityp is not null access I'Class;
- -- Rnn : constant Ityp := Ityp (Tmp.I_Tag'Address);
+ -- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address);
-- CW : I'Class renames Rnn.all;
if Comes_From_Source (Expr_Q)
@@ -7580,14 +7650,55 @@ package body Exp_Ch3 is
(Find_Interface_Tag (Expr_Typ, Iface), Loc));
-- Replace
- -- IW : I'Class := Obj;
+ -- IW : I'Class := Expr;
+ -- by
+ -- Dnn : Tag renames Tag_Ptr!(Expr'Address).all;
+ -- type Ityp is not null access I'Class;
+ -- Rnn : constant Ityp :=
+ -- Ityp!(Displace (Dnn'Address, I'Tag));
+ -- IW : I'Class renames Rnn.all;
+
+ elsif Rewrite_As_Renaming then
+ New_Expr :=
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Expr_Q),
+ Attribute_Name => Name_Address)));
+
+ -- Suppress junk access checks on RE_Tag_Ptr
+
+ Insert_Action (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Obj_Id,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Tag), Loc),
+ Name => New_Expr),
+ Suppress => Access_Check);
+
+ -- Dynamically reference the tag associated with the
+ -- interface.
+
+ Tag_Comp :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Attribute_Name => Name_Address),
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Iface))),
+ Loc)));
+
+ -- Replace
+ -- IW : I'Class := Expr;
-- by
-- type Equiv_Record is record ... end record;
-- implicit subtype CW is <Class_Wide_Subtype>;
- -- Tmp : CW := CW!(Obj);
+ -- Dnn : CW := CW!(Expr);
-- type Ityp is not null access I'Class;
-- Rnn : constant Ityp :=
- -- Ityp!(Displace (Tmp'Address, I'Tag));
+ -- Ityp!(Displace (Dnn'Address, I'Tag));
-- IW : I'Class renames Rnn.all;
else
@@ -7600,13 +7711,10 @@ package body Exp_Ch3 is
Subtype_Indic => Obj_Def,
Exp => Expr_Q);
- if not Is_Interface (Etype (Expr_Q)) then
- New_Expr := Relocate_Node (Expr_Q);
-
-- For interface types we use 'Address which displaces
- -- the pointer to the base of the object (if required)
+ -- the pointer to the base of the object (if required).
- else
+ if Is_Interface (Etype (Expr_Q)) then
New_Expr :=
Unchecked_Convert_To (Etype (Obj_Def),
Make_Explicit_Dereference (Loc,
@@ -7614,33 +7722,23 @@ package body Exp_Ch3 is
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Expr_Q),
Attribute_Name => Name_Address))));
- end if;
-
- -- Copy the object
- if not Is_Limited_Record (Expr_Typ) then
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Obj_Id,
- Object_Definition =>
- New_Occurrence_Of (Etype (Obj_Def), Loc),
- Expression => New_Expr));
-
- -- Rename limited type object since they cannot be copied
- -- This case occurs when the initialization expression
- -- has been previously expanded into a temporary object.
+ -- For other types, no displacement is needed
else
- Insert_Action (N,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Obj_Id,
- Subtype_Mark =>
- New_Occurrence_Of (Etype (Obj_Def), Loc),
- Name =>
- Unchecked_Convert_To
- (Etype (Obj_Def), New_Expr)));
+ New_Expr := Relocate_Node (Expr_Q);
end if;
+ -- Suppress junk access checks on RE_Tag_Ptr
+
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Obj_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Obj_Def), Loc),
+ Expression => New_Expr),
+ Suppress => Access_Check);
+
-- Dynamically reference the tag associated with the
-- interface.
@@ -7684,6 +7782,7 @@ package body Exp_Ch3 is
Set_Prefix (Tag_Comp, New_Occurrence_Of (Ptr_Obj_Id, Loc));
Expr_Q := Tag_Comp;
Set_Etype (Expr_Q, Typ);
+ Set_Parent (Expr_Q, N);
Rewrite_As_Renaming := True;
end;
@@ -7863,7 +7962,6 @@ package body Exp_Ch3 is
Rewrite_As_Renaming :=
-- The declaration cannot be rewritten if it has got constraints
- -- in other words the nominal subtype must be unconstrained.
Is_Entity_Name (Original_Node (Obj_Def))
@@ -7872,57 +7970,18 @@ package body Exp_Ch3 is
and then not Aliased_Present (N)
- -- If the object declaration originally appears in the form
-
- -- Obj : Typ := Func (...);
-
- -- and has been rewritten as the dereference of a reference
- -- to the function result built either on the primary or the
- -- secondary stack, then the declaration can be rewritten as
- -- the renaming of this dereference:
-
- -- type Ann is access all Typ;
- -- Rnn : constant Axx := Func (...)'reference;
- -- Obj : Typ renames Rnn.all;
-
- -- This avoids an extra copy and, in the case where Typ needs
- -- finalization, a pair of Adjust/Finalize calls (see below).
-
- -- However, in the case of a special return object, we need to
- -- make sure that the object Rnn is properly recognized by the
- -- Is_Related_To_Func_Return predicate; otherwise, if it is of
- -- a type that needs finalization, Requires_Cleanup_Actions
- -- would return true because of this and Build_Finalizer would
- -- 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.
+ -- We may use a renaming if the initializing expression is a
+ -- captured function call that meets a few conditions.
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 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:
-
- -- Obj : Typ := Expr;
-
- -- into
+ (Is_Renamable_Function_Call (Expr_Q)
- -- Obj : Typ renames Expr;
+ -- Or else if it is a variable with OK_To_Rename set
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 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))
@@ -8117,8 +8176,8 @@ package body Exp_Ch3 is
if Is_Build_In_Place_Return_Object (Def_Id) then
declare
- Init_Stmt : Node_Id;
- Obj_Acc_Formal : Entity_Id;
+ Init_Stmt : Node_Id;
+ Obj_Acc_Formal : Entity_Id;
begin
-- Retrieve the implicit access parameter passed by the caller
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 7a309e85055..503fdc1ee6b 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -687,7 +687,11 @@ package body Exp_Ch6 is
Loc : constant Source_Ptr := Sloc (Exp);
begin
+ -- CodePeer does not do anything useful on Ada.Tags.Type_Specific_Data
+ -- components.
+
if Ada_Version >= Ada_2005
+ and then not CodePeer_Mode
and then Tagged_Type_Expansion
and then not Scope_Suppress.Suppress (Accessibility_Check)
and then
@@ -770,20 +774,18 @@ package body Exp_Ch6 is
Attribute_Name => Name_Tag);
end if;
- -- CodePeer does not do anything useful with
- -- Ada.Tags.Type_Specific_Data components.
-
- if not CodePeer_Mode then
- Insert_Action (Exp,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Scope_Depth (Enclosing_Dynamic_Scope (Func)))),
- Reason => PE_Accessibility_Check_Failed));
- end if;
+ -- Suppress junk access chacks on RE_Tag_Ptr
+
+ Insert_Action (Exp,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Scope_Depth (Enclosing_Dynamic_Scope (Func)))),
+ Reason => PE_Accessibility_Check_Failed),
+ Suppress => Access_Check);
end;
end if;
end Apply_CW_Accessibility_Check;
--
2.34.1
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-01-16 14:48 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-01-16 14:48 [COMMITTED] ada: Optimize interface 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).