From patchwork Wed Jan 5 11:33:28 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: 1575597 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: bilbo.ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=hwp3qgKJ; dkim-atps=neutral Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Received: from sourceware.org (ip-8-43-85-97.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by bilbo.ozlabs.org (Postfix) with ESMTPS id 4JTSGn08QJz9s9c for ; Wed, 5 Jan 2022 22:40:47 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id E87963858431 for ; Wed, 5 Jan 2022 11:40:44 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org E87963858431 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1641382844; bh=wE3exCDohzgYjXzDGqzIVQtD8bhTdBEwJNq50CJ7nX0=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=hwp3qgKJXsbQH5CDC59i52fYoxAg414oxXwXuaB4Iwbk+XZdbUe3p00vHLgVfpuiL Xshq6gBq+9sZFUhYjIKlKJeUVL68NWsJZ/5tl+IxKRThK4XTw/v2vxbdLHiPSeDHob M4PIv/SscXodqhf/+gEQCGSHpDQNWNQOWrglsY8U= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32e.google.com (mail-wm1-x32e.google.com [IPv6:2a00:1450:4864:20::32e]) by sourceware.org (Postfix) with ESMTPS id C0CF13858437 for ; Wed, 5 Jan 2022 11:33:30 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org C0CF13858437 Received: by mail-wm1-x32e.google.com with SMTP id v10-20020a05600c214a00b00345e59928eeso1695804wml.0 for ; Wed, 05 Jan 2022 03:33:30 -0800 (PST) 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=wE3exCDohzgYjXzDGqzIVQtD8bhTdBEwJNq50CJ7nX0=; b=JbZ/Z/XaKB4T3a4FELDrkZvgY/nA71OKOjJTSGL499Tv6x24pgQidHwEYLZawSdC1C CMcO1jMHHZvc8FAp46I/m+vfUjP0CL4tPoZ7kc/AjRNEDwt/cQBxmdjPV+34xOBYVvHT 0Yhfq00pquZ3WluXEPPCFVyVIAB6U8o1o3P7Ao+99CdrWmUPer6LVtVXIB2GGBHKjSqM TZuZ94yrgHhoDNRYAnU89JLptaEl2qcnhEfwKoGmDVk/FpUn/Po+KzXu4mR15ek67yv0 L6lUKd/wxcIyAk/3o49lulmd51+2SSs3oEXpa2nV7TjitP+QQFTcN4DWI80Z7ZRWCjvG UV4A== X-Gm-Message-State: AOAM531CsiHMTanNoL0+wZVmJrZaMLzPWKfg52yFZdVcA77GakpDfCT3 p6kcjJyBqtU2CJD05ohskZnbq22LdqHN7g== X-Google-Smtp-Source: ABdhPJy1wnIZZQOaKNRczUDb/UY5UWE1yvS8DtZeDTPY/GBkI9wldbuIglqwHo/O2S3PmK7Lc1qtxQ== X-Received: by 2002:a1c:f209:: with SMTP id s9mr2512070wmc.94.1641382409860; Wed, 05 Jan 2022 03:33:29 -0800 (PST) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id c8sm2563530wmq.34.2022.01.05.03.33.29 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 05 Jan 2022 03:33:29 -0800 (PST) Date: Wed, 5 Jan 2022 11:33:28 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Fix sharing of formal parameters between wrapper spec and body Message-ID: <20220105113328.GA2712784@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-13.0 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 autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) 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: Piotr Trojanek Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" When creating wrappers for dispatching functions with controlling results, we first created the wrapper spec. Then we created a shallow copy of its specification for the wrapper body using New_Copy_Tree. However, formal parameters in spec and body must have distinct entities and New_Copy_Tree doesn't create such distinct copies. For GNAT this doesn't seem to be a problem; for GNATprove it causes crashes. A similar routine Make_Null_Procedure_Specs solves this problem by explicitly injecting new entities into the shallow copy created by New_Copy_Tree. In Make_Controlling_Function_Wrappers a more elegant solution is to reuse Copy_Parameter_List. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch3.adb (Make_Controlling_Function_Wrappers): Create distinct copies of parameter lists for spec and body with Copy_Parameter_List; cleanup. (Make_Null_Procedure_Specs): Fix style in comments; remove a potentially unnecessary initialization of a local variable. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -9591,19 +9591,41 @@ package body Exp_Ch3 is Decl_List : out List_Id; Body_List : out List_Id) is - Loc : constant Source_Ptr := Sloc (Tag_Typ); + Loc : constant Source_Ptr := Sloc (Tag_Typ); + + function Make_Wrapper_Specification (Subp : Entity_Id) return Node_Id; + -- Returns a function specification with the same profile as Subp + + -------------------------------- + -- Make_Wrapper_Specification -- + -------------------------------- + + function Make_Wrapper_Specification (Subp : Entity_Id) return Node_Id is + begin + return + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Chars (Subp)), + Parameter_Specifications => + Copy_Parameter_List (Subp), + Result_Definition => + New_Occurrence_Of (Etype (Subp), Loc)); + end Make_Wrapper_Specification; + Prim_Elmt : Elmt_Id; Subp : Entity_Id; Actual_List : List_Id; - Formal_List : List_Id; Formal : Entity_Id; Par_Formal : Entity_Id; Formal_Node : Node_Id; Func_Body : Node_Id; Func_Decl : Node_Id; - Func_Spec : Node_Id; + Func_Id : Entity_Id; Return_Stmt : Node_Id; + -- Start of processing for Make_Controlling_Function_Wrappers + begin Decl_List := New_List; Body_List := New_List; @@ -9674,43 +9696,10 @@ package body Exp_Ch3 is end; end if; - Formal_List := No_List; - Formal := First_Formal (Subp); - - if Present (Formal) then - Formal_List := New_List; - - while Present (Formal) loop - Append - (Make_Parameter_Specification - (Loc, - Defining_Identifier => - Make_Defining_Identifier (Sloc (Formal), - Chars => Chars (Formal)), - In_Present => In_Present (Parent (Formal)), - Out_Present => Out_Present (Parent (Formal)), - Null_Exclusion_Present => - Null_Exclusion_Present (Parent (Formal)), - Parameter_Type => - New_Occurrence_Of (Etype (Formal), Loc), - Expression => - New_Copy_Tree (Expression (Parent (Formal)))), - Formal_List); - - Next_Formal (Formal); - end loop; - end if; - - Func_Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars => Chars (Subp)), - Parameter_Specifications => Formal_List, - Result_Definition => - New_Occurrence_Of (Etype (Subp), Loc)); + Func_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Make_Wrapper_Specification (Subp)); - Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); Append_To (Decl_List, Func_Decl); -- Build a wrapper body that calls the parent function. The body @@ -9723,34 +9712,35 @@ package body Exp_Ch3 is Formal := First_Formal (Subp); Par_Formal := First_Formal (Alias (Subp)); - Formal_Node := First (Formal_List); + Formal_Node := + First (Parameter_Specifications (Specification (Func_Decl))); if Present (Formal) then Actual_List := New_List; - else - Actual_List := No_List; - end if; - while Present (Formal) loop - if Is_Controlling_Formal (Formal) then - Append_To (Actual_List, - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (Etype (Par_Formal), Loc), - Expression => + while Present (Formal) loop + if Is_Controlling_Formal (Formal) then + Append_To (Actual_List, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Par_Formal), Loc), + Expression => + New_Occurrence_Of + (Defining_Identifier (Formal_Node), Loc))); + else + Append_To + (Actual_List, New_Occurrence_Of - (Defining_Identifier (Formal_Node), Loc))); - else - Append_To - (Actual_List, - New_Occurrence_Of - (Defining_Identifier (Formal_Node), Loc)); - end if; + (Defining_Identifier (Formal_Node), Loc)); + end if; - Next_Formal (Formal); - Next_Formal (Par_Formal); - Next (Formal_Node); - end loop; + Next_Formal (Formal); + Next_Formal (Par_Formal); + Next (Formal_Node); + end loop; + else + Actual_List := No_List; + end if; Return_Stmt := Make_Simple_Return_Statement (Loc, @@ -9765,27 +9755,25 @@ package body Exp_Ch3 is Func_Body := Make_Subprogram_Body (Loc, - Specification => New_Copy_Tree (Func_Spec), + Specification => + Make_Wrapper_Specification (Subp), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Return_Stmt))); - Set_Defining_Unit_Name - (Specification (Func_Body), - Make_Defining_Identifier (Loc, Chars (Subp))); - Append_To (Body_List, Func_Body); -- Replace the inherited function with the wrapper function in the -- primitive operations list. We add the minimum decoration needed -- to override interface primitives. - Mutate_Ekind (Defining_Unit_Name (Func_Spec), E_Function); - Set_Is_Wrapper (Defining_Unit_Name (Func_Spec)); + Func_Id := Defining_Unit_Name (Specification (Func_Decl)); - Override_Dispatching_Operation - (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec)); + Mutate_Ekind (Func_Id, E_Function); + Set_Is_Wrapper (Func_Id); + + Override_Dispatching_Operation (Tag_Typ, Subp, New_Op => Func_Id); end if; <> @@ -10297,7 +10285,6 @@ package body Exp_Ch3 is if Present (Parent_Subp) and then Is_Null_Interface_Primitive (Parent_Subp) then - Formal_List := No_List; Formal := First_Formal (Subp); if Present (Formal) then @@ -10311,16 +10298,16 @@ package body Exp_Ch3 is New_Copy_Tree (Parent (Formal), New_Sloc => Loc); -- Generate a new defining identifier for the new formal. - -- required because New_Copy_Tree does not duplicate + -- Required because New_Copy_Tree does not duplicate -- semantic fields (except itypes). Set_Defining_Identifier (New_Param_Spec, Make_Defining_Identifier (Sloc (Formal), Chars => Chars (Formal))); - -- For controlling arguments we must change their - -- parameter type to reference the tagged type (instead - -- of the interface type) + -- For controlling arguments we must change their parameter + -- type to reference the tagged type (instead of the + -- interface type). if Is_Controlling_Formal (Formal) then if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier @@ -10340,6 +10327,8 @@ package body Exp_Ch3 is Next_Formal (Formal); end loop; + else + Formal_List := No_List; end if; Append_To (Decl_List,