From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wr1-x42c.google.com (mail-wr1-x42c.google.com [IPv6:2a00:1450:4864:20::42c]) by sourceware.org (Postfix) with ESMTPS id D8BC33858416 for ; Mon, 16 Jan 2023 14:48:37 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org D8BC33858416 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-wr1-x42c.google.com with SMTP id k8so13211460wrc.9 for ; Mon, 16 Jan 2023 06:48:37 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=Ku2axtMPy3BwZGJSeDkzW2Mape0gOzBN04AhCuAzb6A=; b=e/gviaExgC7NEzDFWYGiN59fnUvhNiFuosIjz9Tqgzpccg4kX2SfKphxHZKV4Rx/6+ iWiDITEZhUjrz20AATUiZ0Sf8CUxktQYcOqHOiA2anJ7KEKllNIhAYcFdTtbVRcL+CAh D387KZTOhejmAXblBtDgH+UTtPQYHL3lOU3RPbU7cXL12QLYJmhM20soQ4D/y2kjtBK7 djFHzQ2HEQWsiTaNW+rSsGKyiwLVjxscpxDGKlZMWfdL2UfZVUCFVaJfz7bfrEnRvylD q1dKBnW95pwDkmD259IvaPd4YG9CkHpgBKSE9HdGDRhN6D2A78gSP/SNP9qiQNhqnBEe dutw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=Ku2axtMPy3BwZGJSeDkzW2Mape0gOzBN04AhCuAzb6A=; b=uSCi42CgZdjJou6PrCv87jqrgzy8qcuDO6z0nPeDS0PfPzGombTQD+OH2sSNvAkeYU ntvXXUBKkeIQ6e6PiC+55/YUe3/0GnuCrqdk3FLQ/K412NCpzSRsZpKosQoXf94LbeVe 9jhKppc6xElfmhMF3pscK84mgJjt/n7XgS6Ciazu8WnjAzf9RsJy8kQwrB8pw4b9ttT5 DE70mD2B3HmFLr6gh+Sf4IQlwZNQ7pslx6dimim1fJN3xTAvtyRbTlCRLWOglaBx9aVy v9CYkEgiK8YXHsnkxilDYo/HZM+MTDmfjIP2n4KgbaSv4nqygG6dcJfj/j8fqAhyK1xb wp2w== X-Gm-Message-State: AFqh2krjInPAaA7TGvRi+Gf8USjiLmetrlQUQk6u4efBKJDdGDYeiGQM agW0jbHHas5mGBJanS8e/VSrgugMIA4z3oJS X-Google-Smtp-Source: AMrXdXsRhbWGU6i+JdxAfsAVvsQXZC79QK/yKTewl5XMvMShmbzkXhOcoNkARyhjK71X2Jv24IFajg== X-Received: by 2002:a5d:474a:0:b0:2be:b0e:21dc with SMTP id o10-20020a5d474a000000b002be0b0e21dcmr2085491wrs.14.1673880516427; Mon, 16 Jan 2023 06:48:36 -0800 (PST) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id n13-20020a5d67cd000000b002bdcce37d31sm14685737wrw.99.2023.01.16.06.48.35 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 16 Jan 2023 06:48:35 -0800 (PST) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Optimize interface objects initialized with function calls Date: Mon, 16 Jan 2023 15:48:32 +0100 Message-Id: <20230116144832.3171227-1-poulhies@adacore.com> X-Mailer: git-send-email 2.34.1 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-12.9 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,GIT_PATCH_0,KAM_ASCII_DIVIDERS,RCVD_IN_DNSWL_NONE,SPF_HELO_NONE,SPF_PASS,TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org List-Id: From: Eric Botcazou 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 ; - -- 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