From patchwork Mon Jul 4 07:50:29 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 55685 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 56A773836649 for ; Mon, 4 Jul 2022 07:57:02 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 56A773836649 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1656921422; bh=t2biupWPG88Y7nve3Vy6YG0wFcrM7nBE93hOrCg7YRM=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=fo8r96TK9cWIDQKLt78j0VaXHYQRKJjXgvKZO++AdDHBpMQpousMpW/fy+pv+DBa0 +WIjUcDe4+dt0Thp/uUy97JUGVjd5d8gCmmlGxN3Uzp3auAuV9y/L6VUGc6rQ8qqUD kfOr+bjf3wJLg4kpDBz7+0wLpA9LUL9D/DsegU2o= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-ej1-x62c.google.com (mail-ej1-x62c.google.com [IPv6:2a00:1450:4864:20::62c]) by sourceware.org (Postfix) with ESMTPS id 2268B385354D for ; Mon, 4 Jul 2022 07:50:31 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 2268B385354D Received: by mail-ej1-x62c.google.com with SMTP id fw3so15210762ejc.10 for ; Mon, 04 Jul 2022 00:50:31 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=t2biupWPG88Y7nve3Vy6YG0wFcrM7nBE93hOrCg7YRM=; b=MnLO8pDxeLzEVCQyUyKEN5SLZOVnNIrX2BS+BedF3lvB6g6ZvswurvMkFyBJUQdigB A+RH4qnhLmEwh195bF+NYXa2hKog6zArwxPhJC5BbbojBGFwi+tARJn5F+ujnzc2bNSk JvhfOZNxADWdHzfa4JvtoxIOZm0vBeeeJKdHb930dYX50SZ+1DfP8czcGqO+Fgjs7pLl DbchtpEFTLbvtQQN5pDlV9YPiM30ouLfxDgP4fthCfRTqlFBfVrjpsOyllDPf9Z0saGv w9OFUZTcIuMzbGnF+yEWAP4GehjI2BQQgMQ3sn0/nzQHGIm+lc8TvZJHK1mmThEksxkx wEcA== X-Gm-Message-State: AJIora+CmgbKiw3ABvwtv96sL93cXJIcDLiYNueJhl1HDKOo6eYG8dYI lJl1c3ZJIMohM5BNiS4QEkFbZ7g/lelQBQ== X-Google-Smtp-Source: AGRyM1u6MuT6avKpNXP+bsCNYrdaaij+Pb9CMt1BZ485kz7G3QM6ErM42LXTaewe2x8W2VSeRyBksg== X-Received: by 2002:a17:906:c78b:b0:722:e80c:dc82 with SMTP id cw11-20020a170906c78b00b00722e80cdc82mr28066920ejb.632.1656921030731; Mon, 04 Jul 2022 00:50:30 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id ba29-20020a0564021add00b00435a62d35b5sm20116713edb.45.2022.07.04.00.50.30 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Jul 2022 00:50:30 -0700 (PDT) Date: Mon, 4 Jul 2022 07:50:29 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Do not make procedure call with only tag-indeternminate actuals dispatching Message-ID: <20220704075029.GA99406@adacore.com> MIME-Version: 1.0 Content-Disposition: inline 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, 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 X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Eric Botcazou Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" The RM 3.9.2(19) clause says that the controlling tag value is statically determined to be the tag of the tagged type involved. As a matter of fact, the call would be made dispatching only as a by-product of the propagation of the controlling tag value to the tag-indeternminate actuals, but that's unnecessary and not done in the equivalent case of a procedure call with both statically tagged and tag-indeternminate actuals. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_disp.adb (Check_Dispatching_Call): Merge the two special cases where there are no controlling actuals but tag-indeternminate ones. diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -540,8 +540,10 @@ package body Sem_Disp is Control : Node_Id := Empty; Func : Entity_Id; Subp_Entity : Entity_Id; - Indeterm_Ancestor_Call : Boolean := False; - Indeterm_Ctrl_Type : Entity_Id := Empty; -- init to avoid warning + + Indeterm_Ctrl_Type : Entity_Id := Empty; + -- Type of a controlling formal whose actual is a tag-indeterminate call + -- whose result type is different from, but is an ancestor of, the type. Static_Tag : Node_Id := Empty; -- If a controlling formal has a statically tagged actual, the tag of @@ -935,8 +937,7 @@ package body Sem_Disp is and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal)) and then Is_Ancestor (Etype (Actual), Etype (Formal)) then - Indeterm_Ancestor_Call := True; - Indeterm_Ctrl_Type := Etype (Formal); + Indeterm_Ctrl_Type := Etype (Formal); -- If the formal is controlling but the actual is not, the type -- of the actual is statically known, and may be used as the @@ -946,39 +947,13 @@ package body Sem_Disp is and then Is_Entity_Name (Actual) and then Is_Tagged_Type (Etype (Actual)) then - Static_Tag := Actual; + Static_Tag := Etype (Actual); end if; Next_Actual (Actual); Next_Formal (Formal); end loop; - -- If the call doesn't have a controlling actual but does have an - -- indeterminate actual that requires dispatching treatment, then an - -- object is needed that will serve as the controlling argument for - -- a dispatching call on the indeterminate actual. This can occur - -- in the unusual situation of a default actual given by a tag- - -- indeterminate call and where the type of the call is an ancestor - -- of the type associated with a containing call to an inherited - -- operation (see AI-239). - - -- Rather than create an object of the tagged type, which would - -- be problematic for various reasons (default initialization, - -- discriminants), the tag of the containing call's associated - -- tagged type is directly used to control the dispatching. - - if No (Control) - and then Indeterm_Ancestor_Call - and then No (Static_Tag) - then - Control := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc), - Attribute_Name => Name_Tag); - - Analyze (Control); - end if; - if Present (Control) then -- Verify that no controlling arguments are statically tagged @@ -1030,17 +1005,35 @@ package body Sem_Disp is Check_Direct_Call; - -- If there is a statically tagged actual and a tag-indeterminate - -- call to a function of the ancestor (such as that provided by a - -- default), then treat this as a dispatching call and propagate - -- the tag to the tag-indeterminate call(s). - - elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then - Control := - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Etype (Static_Tag), Loc), - Attribute_Name => Name_Tag); + -- If the call doesn't have a controlling actual but does have an + -- indeterminate actual that requires dispatching treatment, then an + -- object is needed that will serve as the controlling argument for + -- a dispatching call on the indeterminate actual. This can occur + -- in the unusual situation of a default actual given by a tag- + -- indeterminate call and where the type of the call is an ancestor + -- of the type associated with a containing call to an inherited + -- operation (see AI-239). + + -- Rather than create an object of the tagged type, which would + -- be problematic for various reasons (default initialization, + -- discriminants), the tag of the containing call's associated + -- tagged type is directly used to control the dispatching. + + elsif Present (Indeterm_Ctrl_Type) then + if Present (Static_Tag) then + Control := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Static_Tag, Loc), + Attribute_Name => Name_Tag); + + else + Control := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indeterm_Ctrl_Type, Loc), + Attribute_Name => Name_Tag); + end if; Analyze (Control);