From patchwork Mon Oct 25 15:09:30 2021 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: 46636 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 9775B3858424 for ; Mon, 25 Oct 2021 15:27:05 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 9775B3858424 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1635175625; bh=5e1ve5J0uiJlJ9gUZKTXQv0iyU0iGzhvLYUnMmnja40=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=xqMca1XmCzfL4p5wji0LwXMIMn23ksBrutZ278OiNgKQu7y0P5NS9Fd8awbsLJhOO PrMheIvtP9eUP28ELn7E2ajlaSKbaSCkYH/t+n/xquPP/DqafYr4FIjDriCf5nSOQs +koRWpnQpS9qpEY9Cgi+TkJeWTBoZactU/wYpC24= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lf1-x129.google.com (mail-lf1-x129.google.com [IPv6:2a00:1450:4864:20::129]) by sourceware.org (Postfix) with ESMTPS id 5C1863858015 for ; Mon, 25 Oct 2021 15:09:33 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 5C1863858015 Received: by mail-lf1-x129.google.com with SMTP id x27so10123233lfu.5 for ; Mon, 25 Oct 2021 08:09:33 -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=5e1ve5J0uiJlJ9gUZKTXQv0iyU0iGzhvLYUnMmnja40=; b=xFKboSvPPkF7+elyXeg7pTP5p0lCU0NHb+raz+DnARCg4OK8bbjRGa6qpUZIvNApo3 mj3h1ew/o7pjAkcc5RUFBhwu1GwQCM8IPGSmmmpJ07Ssf8PjhwBPvT9my4jyppC7y46h UpbRztwCTMAMTDGgH8NNXyPPiSNUhn9C0zZw5txQZbkNMz5XvvKilKFs/Om7T0uOcZvU UmnTPxIJOB5bMlkWISnROH01hmXEgeZtUGvp11OBhbh4hU4WQn2AqZhcLY1mrHnoZhhk bi4HgFR9vKxGs3osm9Y3e2uIHjHBV3y+cORCa6mHueoi2VnZdC9kX3ycjuRs+2yYz5tn Fnug== X-Gm-Message-State: AOAM531kjqU8fwmhuhiDv7iCf5Nc1TgnHxczq+eb0mBEV6dPkZeyjvGC Hv8L8vrJRRLceg08gaV8sm87IbxYmhKpIflU X-Google-Smtp-Source: ABdhPJxT+jW1uPzKadRcthbBSr+OIJ83SQERlOJ2EYYZpdIYcrf2LejVBX3l2P2E9xW5l1FoOX7zpg== X-Received: by 2002:ac2:4213:: with SMTP id y19mr703349lfh.462.1635174572265; Mon, 25 Oct 2021 08:09:32 -0700 (PDT) Received: from adacore.com ([2a02:2ab8:224:2ce:72b5:e8ff:feef:ee60]) by smtp.gmail.com with ESMTPSA id p10sm1765459ljm.53.2021.10.25.08.09.31 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 25 Oct 2021 08:09:31 -0700 (PDT) Date: Mon, 25 Oct 2021 15:09:30 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Fix bugs in Base_Type_Only (etc.) fields Message-ID: <20211025150930.GA346778@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: Bob Duff Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" If a field has Type_Only set to something other than No_Type_Only, then we need to fetch the field from a possibly different node. For example, the Modulus field has Type_Only = Base_Type_Only (and is documented as a "[base type only]" field in Einfo). Therefore if we try to get Modulus from node N, we must actually get it from Base_Type(N), not from N. This was working correctly for the normal getters generated by Gen_IL. However, when using Field_Descriptors to fetch fields (see package Seinfo), the Type_Only aspect was ignored. This patch fixes that bug. Treepr is the main place where Field_Descriptors are used to fetch fields, so the effect of the bug was mainly to cause Treepr to print wrong information. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * gen_il-gen.adb (Put_Seinfo): Generate type Seinfo.Type_Only_Enum based on type Gen_IL.Internals.Type_Only_Enum. Automatically generating a copy of the type will help keep them in sync. (Note that there are no Ada compiler packages imported into Gen_IL.) Add a Type_Only field to Field_Descriptor, so this information is available in the Ada compiler (as opposed to just in the Gen_IL "compiler"). (One_Comp): Add initialization of the Type_Only field of Field_Descriptor. * gen_il-internals.ads (Image): Image function for Type_Only_Enum. * atree.ads (Node_To_Fetch_From): New function to compute which node to fetch from, based on the Type_Only aspect. * atree.adb (Get_Field_Value): Call Node_To_Fetch_From. * treepr.adb (Print_Entity_Field): Call Node_To_Fetch_From. (Print_Node_Field): Assert. * sinfo-utils.adb (Walk_Sinfo_Fields, Walk_Sinfo_Fields_Pairwise): Asserts. diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -854,14 +854,15 @@ package body Atree is (N : Node_Id; Field : Node_Or_Entity_Field) return Field_Size_32_Bit is Desc : Field_Descriptor renames Field_Descriptors (Field); + NN : constant Node_Or_Entity_Id := Node_To_Fetch_From (N, Field); begin case Field_Size (Desc.Kind) is - when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (N, Desc.Offset)); - when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (N, Desc.Offset)); - when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (N, Desc.Offset)); - when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (N, Desc.Offset)); - when others => return Get_32_Bit_Val (N, Desc.Offset); -- 32 + when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (NN, Desc.Offset)); + when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (NN, Desc.Offset)); + when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (NN, Desc.Offset)); + when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (NN, Desc.Offset)); + when others => return Get_32_Bit_Val (NN, Desc.Offset); -- 32 end case; end Get_Field_Value; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -47,6 +47,7 @@ with Alloc; with Sinfo.Nodes; use Sinfo.Nodes; with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; with Types; use Types; with Seinfo; use Seinfo; with System; use System; @@ -616,6 +617,20 @@ package Atree is -- always the same; for example we change from E_Void, to E_Variable, to -- E_Void, to E_Constant. + function Node_To_Fetch_From + (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field) + return Node_Or_Entity_Id is + (case Field_Descriptors (Field).Type_Only is + when No_Type_Only => N, + when Base_Type_Only => Base_Type (N), + when Impl_Base_Type_Only => Implementation_Base_Type (N), + when Root_Type_Only => Root_Type (N)); + -- This is analogous to the same-named function in Gen_IL.Gen. Normally, + -- Type_Only is No_Type_Only, and we fetch the field from the node N. But + -- if Type_Only = Base_Type_Only, we need to go to the Base_Type, and + -- similarly for the other two cases. This can return something other + -- than N only if N is an Entity. + ----------------------------- -- Private Part Subpackage -- ----------------------------- diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -2157,7 +2157,8 @@ package body Gen_IL.Gen is Put (S, F_Image (F) & " => (" & Image (Field_Table (F).Field_Type) & "_Field, " & - Image (Offset) & ")"); + Image (Offset) & ", " & + Image (Field_Table (F).Type_Only) & ")"); FS := Field_Size (F); FB := First_Bit (F, Offset); @@ -2252,10 +2253,32 @@ package body Gen_IL.Gen is Decrease_Indent (S, 2); Put (S, ");" & LF & LF); + Put (S, "type Type_Only_Enum is" & LF); + Increase_Indent (S, 2); + Put (S, "("); + + declare + First_Time : Boolean := True; + begin + for TO in Type_Only_Enum loop + if First_Time then + First_Time := False; + else + Put (S, ", "); + end if; + + Put (S, Image (TO)); + end loop; + end; + + Decrease_Indent (S, 2); + Put (S, ");" & LF & LF); + Put (S, "type Field_Descriptor is record" & LF); Increase_Indent (S, 3); Put (S, "Kind : Field_Kind;" & LF); Put (S, "Offset : Field_Offset;" & LF); + Put (S, "Type_Only : Type_Only_Enum;" & LF); Decrease_Indent (S, 3); Put (S, "end record;" & LF & LF); diff --git a/gcc/ada/gen_il-internals.ads b/gcc/ada/gen_il-internals.ads --- a/gcc/ada/gen_il-internals.ads +++ b/gcc/ada/gen_il-internals.ads @@ -147,6 +147,9 @@ package Gen_IL.Internals is -- The default is No_Type_Only, indicating the field is not one of -- these special "[... only]" ones. + function Image (Type_Only : Type_Only_Enum) return String is + (Capitalize (Type_Only'Img)); + Unknown_Offset : constant := -1; -- Initial value of Offset, so we can tell whether it has been set diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb --- a/gcc/ada/sinfo-utils.adb +++ b/gcc/ada/sinfo-utils.adb @@ -279,6 +279,8 @@ package body Sinfo.Utils is declare Desc : Field_Descriptor renames Field_Descriptors (Fields (J)); + pragma Assert (Desc.Type_Only = No_Type_Only); + -- Type_Only is for entities begin if Is_In_Union_Id (Desc.Kind) then Action (Get_Node_Field_Union (N, Desc.Offset)); @@ -304,6 +306,8 @@ package body Sinfo.Utils is declare Desc : Field_Descriptor renames Field_Descriptors (Fields (J)); + pragma Assert (Desc.Type_Only = No_Type_Only); + -- Type_Only is for entities begin if Is_In_Union_Id (Desc.Kind) then Set_Node_Field_Union diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -1024,6 +1024,8 @@ package body Treepr is FD : Field_Descriptor; Format : UI_Format := Auto) is + pragma Assert (FD.Type_Only = No_Type_Only); + -- Type_Only is for entities begin if not Field_Is_Initial_Zero (N, Field) then Print_Field (Prefix, Image (Field), N, FD, Format); @@ -1041,9 +1043,10 @@ package body Treepr is FD : Field_Descriptor; Format : UI_Format := Auto) is + NN : constant Node_Id := Node_To_Fetch_From (N, Field); begin if not Field_Is_Initial_Zero (N, Field) then - Print_Field (Prefix, Image (Field), N, FD, Format); + Print_Field (Prefix, Image (Field), NN, FD, Format); end if; end Print_Entity_Field;