From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 7871) id 42B70385B524; Thu, 5 Jan 2023 14:39:06 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 42B70385B524 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1672929546; bh=mFp0rfvkgoDH3upO4U4qto00KiBhXtcXPnKLu7pndv0=; h=From:To:Subject:Date:From; b=hthbmZq2H0NNEi7fyWU+Qd7u7ofX+g2EiTGluUhYc4rjdq0Bml3u3gNmPD5G84XIr K+NwSHtRd1sjuZ7rzucWUxO8zbNFMiQUNXpQcOcfbi/UoeM36bZLbFXWO0VERu8Jp5 veziRNj3oUZoH2sHRcwHLAfavO2aC9yVkRzG33kk= 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-5024] ada: Optimize class-wide objects initialized with function calls X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/master X-Git-Oldrev: 229f5150ad6e233a0b2e0cd9f8b09072a566aa96 X-Git-Newrev: 133a8e6339ff5d4c695cd1c4ee0f4958386d46bd Message-Id: <20230105143906.42B70385B524@sourceware.org> Date: Thu, 5 Jan 2023 14:39:06 +0000 (GMT) List-Id: https://gcc.gnu.org/g:133a8e6339ff5d4c695cd1c4ee0f4958386d46bd commit r13-5024-g133a8e6339ff5d4c695cd1c4ee0f4958386d46bd Author: Eric Botcazou Date: Mon Dec 19 11:47:38 2022 +0100 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) : 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. Diff: --- 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)))))));