From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 7871) id 8CBE53858413; Mon, 16 Jan 2023 14:48:37 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 8CBE53858413 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1673880517; bh=g05jXeu6plopVElyWU1PVu+ya0ANWhgmt4BQzUz6tK4=; h=From:To:Subject:Date:From; b=WM2Kqbb9f0jm9CTv1W3soF+xq9WTZaFdSFoUTfpf8QJfoWOCWxKbSfCI+ZekWFEiE /ov16STwuQaFlPi/A7OTc43+LcaL534d9Yt3YxPk/2Rm82A7uPfi07AJe3rhFvzw/f DWu77VLb6QIeDu5XewnnpEh4ZDORDTHiFx8BWXYk= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Marc Poulhi?s To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-5209] ada: Use static references to tag in more cases for interface objects X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/master X-Git-Oldrev: b7ed6c43a80e06082baad5336be0fa943a878d40 X-Git-Newrev: 39a7b603380c6f4383357a6ae1d6c516dc677f29 Message-Id: <20230116144837.8CBE53858413@sourceware.org> Date: Mon, 16 Jan 2023 14:48:37 +0000 (GMT) List-Id: https://gcc.gnu.org/g:39a7b603380c6f4383357a6ae1d6c516dc677f29 commit r13-5209-g39a7b603380c6f4383357a6ae1d6c516dc677f29 Author: Eric Botcazou Date: Sat Jan 7 22:05:58 2023 +0100 ada: Use static references to tag in more cases for interface objects This extends the use of static references to the interface tag in more cases for (class-wide) interface objects, e.g. for initialization expressions that are qualified aggregates or nondispatching calls returning a specific tagged type implementing the interface. gcc/ada/ * exp_util.ads (Has_Tag_Of_Type): Declare. * exp_util.adb (Has_Tag_Of_Type): Move to package level. Recurse on qualified expressions. * exp_ch3.adb (Expand_N_Object_Declaration): Use a static reference to the interface tag in more cases for class-wide interface objects. Diff: --- gcc/ada/exp_ch3.adb | 72 ++++++++++++++++----------------- gcc/ada/exp_util.adb | 112 ++++++++++++++++++++++++++------------------------- gcc/ada/exp_util.ads | 4 ++ 3 files changed, 95 insertions(+), 93 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index bbb53fc6e49..6bc76aec5d1 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7564,7 +7564,7 @@ package body Exp_Ch3 is Expr_Q := Expr; end if; - -- We may use a renaming if the initializing expression is a + -- We may use a renaming if the initialization expression is a -- captured function call that meets a few conditions. Rewrite_As_Renaming := Is_Renamable_Function_Call (Expr_Q); @@ -7621,41 +7621,6 @@ package body Exp_Ch3 is Obj_Id := Make_Temporary (Loc, 'D', Expr_Q); - -- Replace - -- CW : I'Class := Obj; - -- by - -- Dnn : Typ := Obj; - -- type Ityp is not null access I'Class; - -- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address); - -- CW : I'Class renames Rnn.all; - - if Comes_From_Source (Expr_Q) - and then Is_Entity_Name (Expr_Q) - and then not Is_Interface (Expr_Typ) - and then Interface_Present_In_Ancestor (Expr_Typ, Typ) - and then (Expr_Typ = Etype (Expr_Typ) - or else not - Is_Variable_Size_Record (Etype (Expr_Typ))) - then - -- Copy the object - - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Obj_Id, - Object_Definition => - New_Occurrence_Of (Expr_Typ, Loc), - Expression => Relocate_Node (Expr_Q))); - - -- Statically reference the tag associated with the - -- interface - - Tag_Comp := - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Obj_Id, Loc), - Selector_Name => - New_Occurrence_Of - (Find_Interface_Tag (Expr_Typ, Iface), Loc)); - -- Replace -- IW : I'Class := Expr; -- by @@ -7665,7 +7630,7 @@ package body Exp_Ch3 is -- Ityp!(Displace (Dnn'Address, I'Tag)); -- IW : I'Class renames Rnn.all; - elsif Rewrite_As_Renaming then + if Rewrite_As_Renaming then New_Expr := Make_Explicit_Dereference (Loc, Unchecked_Convert_To (RTE (RE_Tag_Ptr), @@ -7697,6 +7662,37 @@ package body Exp_Ch3 is (Node (First_Elmt (Access_Disp_Table (Iface))), Loc))); + -- Replace + -- IW : I'Class := Expr; + -- by + -- Dnn : Typ := Expr; + -- type Ityp is not null access I'Class; + -- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address); + -- IW : I'Class renames Rnn.all; + + elsif Has_Tag_Of_Type (Expr_Q) + and then Interface_Present_In_Ancestor (Expr_Typ, Typ) + and then (Expr_Typ = Etype (Expr_Typ) + or else not + Is_Variable_Size_Record (Etype (Expr_Typ))) + then + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => + New_Occurrence_Of (Expr_Typ, Loc), + Expression => Relocate_Node (Expr_Q))); + + -- Statically reference the tag associated with the + -- interface + + Tag_Comp := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Selector_Name => + New_Occurrence_Of + (Find_Interface_Tag (Expr_Typ, Iface), Loc)); + -- Replace -- IW : I'Class := Expr; -- by @@ -7977,7 +7973,7 @@ package body Exp_Ch3 is and then not (Is_Array_Type (Typ) and then Is_Constr_Subt_For_UN_Aliased (Typ)) - -- We may use a renaming if the initializing expression is a + -- We may use a renaming if the initialization expression is a -- captured function call that meets a few conditions. and then diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index f6d91ca4a0e..80c01bf40fd 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -7186,6 +7186,63 @@ package body Exp_Util is end if; end Has_Access_Constraint; + --------------------- + -- 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 E_Constant | E_Variable + then + return True; + + else + case Nkind (Exp) 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); + + -- For a tagged type, the operand of a qualified expression + -- shall resolve to be of the type of the expression. + + when N_Qualified_Expression => + return Has_Tag_Of_Type (Expression (Exp)); + + when others => + return False; + end case; + end if; + end Has_Tag_Of_Type; + -------------------- -- Homonym_Number -- -------------------- @@ -9491,61 +9548,6 @@ package body Exp_Util is Size_Attr : Node_Id; Size_Expr : 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 E_Constant | E_Variable - then - return True; - - else - case Nkind (Exp) 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 -- in the expression. diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 32f9c24814b..3dd10d77cea 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -732,6 +732,10 @@ package Exp_Util is function Has_Access_Constraint (E : Entity_Id) return Boolean; -- Given object or type E, determine if a discriminant is of an access type + 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). + function Homonym_Number (Subp : Entity_Id) return Pos; -- Here subp is the entity for a subprogram. This routine returns the -- homonym number used to disambiguate overloaded subprograms in the same