From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wm1-x32b.google.com (mail-wm1-x32b.google.com [IPv6:2a00:1450:4864:20::32b]) by sourceware.org (Postfix) with ESMTPS id 324043858039 for ; Tue, 13 Jun 2023 07:38:01 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 324043858039 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-x32b.google.com with SMTP id 5b1f17b1804b1-3f8d2bfed53so751815e9.1 for ; Tue, 13 Jun 2023 00:38:01 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1686641880; x=1689233880; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=qHI6Qc5Ga6sniLvPyUDSpvxR5uWgI51WsiYhhsJjGB4=; b=k2WiHYW8mnP4qhp5FFPfcme+GiAZwNJ6/sanaCr4Cq0ecYq9rWxQFQSEg+06SnGVKr e5aR+V42bOQe4QMCQaI0e+nyJkTb3bgJU/mQEmon9vZz6GYh3LoDHAFZqmx0xO6Z9aFr lLiXTwaOyDdl/AT+cxtoSrTROZsOgGycchM32SLW12SFHSjhkmwOd3qBtCpjFJWDhOsV fVRP/d++9PumdS2P80ovREF9uImawROC8hAk5+EEkbnka2a45fTc7Qqg2BdO3zH1tiNX TQpK/DrqaudceoX9pcdqBwv2MccwucQkwewWKieweCRpWtF4LsVwxAbX0K9S4JMRlDjH fQ5g== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1686641880; x=1689233880; 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=qHI6Qc5Ga6sniLvPyUDSpvxR5uWgI51WsiYhhsJjGB4=; b=MTcp0D0Iah53hPW4xMs0DfD7gSuRj7NjWHWylekXX+sjSMyC71Q6YL7bwtcokVGKig XDTZPGmiUulhux/EBQ4ptA8DrRli/2L3bj7LOfyqXFkv+stUZoT4p1YjDjpZLqFR5TAf 75iRjdDdEsBrxAyBXAITvbUTWi7/CO3QDzxj+nHtPttlqMPM0daIeLTeUNwkQ2dRL8Uw KtGdI7tN5L98noGnnZ5aEZVp7m1WgO3WH5+Na2j4rORvWpYILYG5iTFtYXOnAT09+6nM cuhS6OcefnKHeZ2yLva+fu7JGAs5CpTaYX3FfEyZiQJsxFp8m19dB0WLt4n8nTp0uhZF H0Gg== X-Gm-Message-State: AC+VfDxFNDJ+aKgD5ZtlmiNAhkaZhBwVudjmDK31vLC+CUB7AEuiTjj4 69yHYNDbKQzC6mfrxOfOWx2eMpERXlk1096TNdzLdQ== X-Google-Smtp-Source: ACHHUZ4PDuUPrLNb2tOtMBivfQVjtFl0oTXWX2msdWECfHydNPCb0iNlBEr5D0NNUWl2TdNC+726yA== X-Received: by 2002:a1c:ed03:0:b0:3f7:2c74:896a with SMTP id l3-20020a1ced03000000b003f72c74896amr9262187wmh.19.1686641879970; Tue, 13 Jun 2023 00:37:59 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:bfa8:5d29:40e5:cc66]) by smtp.gmail.com with ESMTPSA id w18-20020a05600018d200b0030af54c5f33sm14481391wrq.113.2023.06.13.00.37.59 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 13 Jun 2023 00:37:59 -0700 (PDT) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Factor out tag assignments from type in expander Date: Tue, 13 Jun 2023 09:37:58 +0200 Message-Id: <20230613073758.239469-1-poulhies@adacore.com> X-Mailer: git-send-email 2.40.0 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-13.2 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,T_SCC_BODY_TEXT_LINE 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 They are performed in a few different places during expansion. gcc/ada/ * exp_util.ads (Make_Tag_Assignment_From_Type): Declare. * exp_util.adb (Make_Tag_Assignment_From_Type): New function. * exp_aggr.adb (Build_Record_Aggr_Code): Call the above function. (Initialize_Simple_Component): Likewise. * exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): Likewise. (Build_Record_Init_Proc.Build_Init_Procedure ): Likewise. (Make_Tag_Assignment): Likewise. Rename local variable and call Unqualify to go through qualified expressions. * exp_ch4.adb (Expand_Allocator_Expression): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 47 ++++------------------------- gcc/ada/exp_ch3.adb | 72 +++++++++----------------------------------- gcc/ada/exp_ch4.adb | 28 ++--------------- gcc/ada/exp_util.adb | 27 +++++++++++++++++ gcc/ada/exp_util.ads | 7 +++++ 5 files changed, 57 insertions(+), 124 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 8c6c9f97429..c145d79f482 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -3095,22 +3095,9 @@ package body Exp_Aggr is if Tagged_Type_Expansion then Instr := - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Base_Type (Typ)), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt - (Access_Disp_Table (Base_Type (Typ)))), - Loc))); + Make_Tag_Assignment_From_Type + (Loc, New_Copy_Tree (Target), Base_Type (Typ)); - Set_Assignment_OK (Name (Instr)); Append_To (Assign, Instr); -- Ada 2005 (AI-251): If tagged type has progenitors we must @@ -3629,19 +3616,8 @@ package body Exp_Aggr is elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then Instr := - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Base_Type (Typ)), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))), - Loc))); + Make_Tag_Assignment_From_Type + (Loc, New_Copy_Tree (Target), Base_Type (Typ)); Append_To (L, Instr); @@ -8761,19 +8737,8 @@ package body Exp_Aggr is and then Is_Tagged_Type (Comp_Typ) then Append_To (Blk_Stmts, - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Comp), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Full_Typ), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Full_Typ))), - Loc)))); + Make_Tag_Assignment_From_Type + (Loc, New_Copy_Tree (Comp), Full_Typ)); end if; -- Adjust the component. In the case of an array aggregate, controlled diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 91dcfa0f643..fbedc16ddd0 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2150,21 +2150,10 @@ package body Exp_Ch3 is and then Nkind (Exp_Q) /= N_Raise_Expression then Append_To (Res, - Make_Assignment_Statement (Default_Loc, - Name => - Make_Selected_Component (Default_Loc, - Prefix => - New_Copy_Tree (Lhs, New_Scope => Proc_Id), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Typ), Default_Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Underlying_Type - (Typ)))), - Default_Loc)))); + Make_Tag_Assignment_From_Type + (Default_Loc, + New_Copy_Tree (Lhs, New_Scope => Proc_Id), + Underlying_Type (Typ))); end if; -- Adjust the component if controlled except if it is an aggregate @@ -2791,17 +2780,8 @@ package body Exp_Ch3 is -- Initialize the primary tag component Init_Tags_List := New_List ( - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Rec_Type), Loc)), - Expression => - New_Occurrence_Of - (Node - (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); + Make_Tag_Assignment_From_Type + (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type)); -- Ada 2005 (AI-251): Initialize the secondary tags components -- located at fixed positions (tags whose position depends on @@ -2880,17 +2860,8 @@ package body Exp_Ch3 is -- Initialize the primary tag Init_Tags_List := New_List ( - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Rec_Type), Loc)), - Expression => - New_Occurrence_Of - (Node - (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); + Make_Tag_Assignment_From_Type + (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type)); -- Ada 2005 (AI-251): Initialize the secondary tags components -- located at fixed positions (tags whose position depends on @@ -12078,13 +12049,11 @@ package body Exp_Ch3 is function Make_Tag_Assignment (N : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); - Def_If : constant Entity_Id := Defining_Identifier (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); Expr : constant Node_Id := Expression (N); - Typ : constant Entity_Id := Etype (Def_If); + Typ : constant Entity_Id := Etype (Def_Id); Full_Typ : constant Entity_Id := Underlying_Type (Typ); - New_Ref : Node_Id; - begin -- This expansion activity is called during analysis @@ -12092,25 +12061,12 @@ package body Exp_Ch3 is and then not Is_Class_Wide_Type (Typ) and then not Is_CPP_Class (Typ) and then Tagged_Type_Expansion - and then Nkind (Expr) /= N_Aggregate - and then (Nkind (Expr) /= N_Qualified_Expression - or else Nkind (Expression (Expr)) /= N_Aggregate) + and then Nkind (Unqualify (Expr)) /= N_Aggregate then - New_Ref := - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Def_If, Loc), - Selector_Name => - New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc)); - - Set_Assignment_OK (New_Ref); - return - Make_Assignment_Statement (Loc, - Name => New_Ref, - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Full_Typ))), Loc))); + Make_Tag_Assignment_From_Type + (Loc, New_Occurrence_Of (Def_Id, Loc), Full_Typ); + else return Empty; end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 537d7a6311c..fdaeb50512f 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -567,7 +567,6 @@ package body Exp_Ch4 is Adj_Call : Node_Id; Aggr_In_Place : Boolean; Node : Node_Id; - Tag_Assign : Node_Id; Temp : Entity_Id; Temp_Decl : Node_Id; @@ -923,30 +922,9 @@ package body Exp_Ch4 is end if; if Present (TagT) then - declare - Full_T : constant Entity_Id := Underlying_Type (TagT); - - begin - Tag_Assign := - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => TagR, - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Full_T), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Elists.Node - (First_Elmt (Access_Disp_Table (Full_T))), Loc))); - end; - - -- The previous assignment has to be done in any case - - Set_Assignment_OK (Name (Tag_Assign)); - Insert_Action (N, Tag_Assign); + Insert_Action (N, + Make_Tag_Assignment_From_Type + (Loc, TagR, Underlying_Type (TagT))); end if; -- Generate an Adjust call if the object will be moved. In Ada 2005, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index da2d8137f6b..def027f2db6 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -10335,6 +10335,33 @@ package body Exp_Util is Constraints => List_Constr)); end Make_Subtype_From_Expr; + ----------------------------------- + -- Make_Tag_Assignment_From_Type -- + ----------------------------------- + + function Make_Tag_Assignment_From_Type + (Loc : Source_Ptr; + Target : Node_Id; + Typ : Entity_Id) return Node_Id + is + Nam : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Target, + Selector_Name => + New_Occurrence_Of (First_Tag_Component (Typ), Loc)); + + begin + Set_Assignment_OK (Nam); + + return + Make_Assignment_Statement (Loc, + Name => Nam, + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); + end Make_Tag_Assignment_From_Type; + ----------------------------- -- Make_Variant_Comparison -- ----------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index eef6800f371..06bd4141c27 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -925,6 +925,13 @@ package Exp_Util is -- wide type. Set Related_Id to request an external name for the subtype -- rather than an internal temporary. + function Make_Tag_Assignment_From_Type + (Loc : Source_Ptr; + Target : Node_Id; + Typ : Entity_Id) return Node_Id; + -- Return an assignment of the tag of tagged type Typ to prefix Target, + -- which must be a record object of a descendant of Typ. + function Make_Variant_Comparison (Loc : Source_Ptr; Typ : Entity_Id; -- 2.40.0