From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wm1-x335.google.com (mail-wm1-x335.google.com [IPv6:2a00:1450:4864:20::335]) by sourceware.org (Postfix) with ESMTPS id DF7CC3857B8E for ; Thu, 5 Jan 2023 14:40:43 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org DF7CC3857B8E 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-wm1-x335.google.com with SMTP id o15so28168554wmr.4 for ; Thu, 05 Jan 2023 06:40:43 -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=U61hPaZa5kH/jx9Jq/07I/xBc8abow1jDW/FEF17Et4=; b=NSuLSZi/QCDUY7RgcgfgSh4t9JURiuTWL4qcOd5lbnnMf1ZMid+Jle2wwIrhCyOpjS +MIMAyWmWQgL62gLgaDXZ3qcDF1GKfZN3SgkPKgdTjB/zJSBSasQXRJnYKpW8vXeaQNf vesoxyBsViK2OA5p0pkBOpCON63yCMYPPU3uDr02cfdSjnmEkhnCYku7pFxduWSX0caJ iRFMpcrfRYrFl99kMyJz5KupIiq7Sl6Jp6yR4dtzEti805OM5bKgRyGAbliqRJHdN0bk 0twd3vVOC+u7bzIme0ZxoNUGTDx6zhSBIOMuBfrkLM1s+I0TD9a7B+1xj8hN5o8iG5sZ iQDw== 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=U61hPaZa5kH/jx9Jq/07I/xBc8abow1jDW/FEF17Et4=; b=Rvi8f6XJbKFfkAo7AT7s4qCbTUaNYHTEcslc3umxPgQXdENfL3RUF6manir35o7q/A wqJoZk+EVeqabcymWEIpyLVUtgaQdbW14fgSw/CJ/nJIZeR6XlLQfcbuTlIP7ci0/mN3 xnrBibumLaPVhinPMWfXs+F6XVbbeKiOHRAbP2R1i85vdL1lJPC1Bn98XErhzrmpQbqL RgayI58VR53M4nA1AC/s6Kbgw+tfCoxTli10A0lIPNM7CVJtR+gnwNiBDoKAReFHMp+4 nh7+4kkK+4+mBkSApPNN4wqQ0Q7I6RJItIQlgsvRwi4iFnfckV2IQsQ4il0nDQVUIQ+G XpQQ== X-Gm-Message-State: AFqh2kq+lf5AYFt4N+fYXwdBYJm2EfeD/DII2uvqvIXIZEdqmbl5jGV8 WKSbgNPMp/kmUl5wVIePpBSwxx/eAzKjrAhURGw= X-Google-Smtp-Source: AMrXdXsIjDLuvrc69FTDoG4nSK2stPIPbu07WF1f2DfV6jOeHR2wrORrxm2adBbk9d3N2pNoJ6nTyA== X-Received: by 2002:a05:600c:1d2a:b0:3d3:50b9:b1a1 with SMTP id l42-20020a05600c1d2a00b003d350b9b1a1mr39946655wms.1.1672929642735; Thu, 05 Jan 2023 06:40:42 -0800 (PST) Received: from poulhies-Precision-5550.lan (static-176-191-105-132.ftth.abo.bbox.fr. [176.191.105.132]) by smtp.gmail.com with ESMTPSA id n17-20020a05600c4f9100b003cffd3c3d6csm2984083wmq.12.2023.01.05.06.40.41 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 05 Jan 2023 06:40:42 -0800 (PST) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Optimize class-wide objects initialized with function calls Date: Thu, 5 Jan 2023 15:40:40 +0100 Message-Id: <20230105144040.156244-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=-10.6 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,GIT_PATCH_0,RCVD_IN_DNSWL_NONE,SPAM_BODY,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 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. 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