From patchwork Tue Jul 7 09:27:36 2020 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: 1324235 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (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 ozlabs.org (Postfix) with ESMTPS id 4B1HFX1rvlz9sRR for ; Tue, 7 Jul 2020 19:29:20 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id C00B93861910; Tue, 7 Jul 2020 09:27:50 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from rock.gnat.com (rock.gnat.com [IPv6:2620:20:4000:0:a9e:1ff:fe9b:1d1]) by sourceware.org (Postfix) with ESMTP id 85594386102F for ; Tue, 7 Jul 2020 09:27:39 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 85594386102F Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=derodat@adacore.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id EAE1B5610D; Tue, 7 Jul 2020 05:27:36 -0400 (EDT) X-Virus-Scanned: Debian amavisd-new at gnat.com Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id 6Bo+wly8gg1k; Tue, 7 Jul 2020 05:27:36 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id B6E0E56106; Tue, 7 Jul 2020 05:27:36 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id B4292156; Tue, 7 Jul 2020 05:27:36 -0400 (EDT) Date: Tue, 7 Jul 2020 05:27:36 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] ACATS 4.1K - C452003 Message-ID: <20200707092736.GA41651@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-7.7 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_ASCII_DIVIDERS, KAM_DMARC_STATUS, KAM_NUMSUBJECT, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) 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: , Cc: Arnaud Charlet Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" This test generates an assertion failure when compiling c452003_root-child.adb and shows that we are missing a null check in membership tests. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch4.adb (Tagged_Membership): Generate a call to CW_Membership instead of using Build_CW_Membership. (Expand_N_In): Remove wrong handling of null access types and corresponding comment. * exp_intr.adb (Expand_Dispatching_Constructor_Call): Generate a call to CW_Membership instead of using Build_CW_Membership. * rtsfind.ads: Add CW_Membership. * exp_atag.ads, exp_atag.adb (Build_CW_Membership): Removed. * einfo.ads: Fix typo. * libgnat/a-tags.ads, libgnat/a-tags.adb (CW_Membership): Moved back to spec. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -591,7 +591,7 @@ package Einfo is -- never have a null value. Set for constant access values initialized to -- a non-null value. This is also set for all access parameters in Ada 83 -- and Ada 95 modes, and for access parameters that explicitly exclude --- exclude null in Ada 2005 mode. +-- null in Ada 2005 mode. -- -- This is used to avoid unnecessary resetting of the Is_Known_Non_Null -- flag for such entities. In Ada 2005 mode, this is also used when diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -27,7 +27,6 @@ with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; with Exp_Disp; use Exp_Disp; -with Exp_Util; use Exp_Util; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -159,118 +158,6 @@ package body Exp_Atag is Make_Simple_Return_Statement (Loc)))); end Build_Common_Dispatching_Select_Statements; - ------------------------- - -- Build_CW_Membership -- - ------------------------- - - procedure Build_CW_Membership - (Loc : Source_Ptr; - Obj_Tag_Node : in out Node_Id; - Typ_Tag_Node : Node_Id; - Related_Nod : Node_Id; - New_Node : out Node_Id) - is - Tag_Addr : constant Entity_Id := Make_Temporary (Loc, 'D', Obj_Tag_Node); - Obj_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); - Typ_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); - Index : constant Entity_Id := Make_Temporary (Loc, 'D'); - - begin - -- Generate: - - -- Tag_Addr : constant Tag := Address!(Obj_Tag); - -- Obj_TSD : constant Type_Specific_Data_Ptr - -- := Build_TSD (Tag_Addr); - -- Typ_TSD : constant Type_Specific_Data_Ptr - -- := Build_TSD (Address!(Typ_Tag)); - -- Index : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth - -- Index >= 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag - - Insert_Action (Related_Nod, - Make_Object_Declaration (Loc, - Defining_Identifier => Tag_Addr, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), - Expression => Unchecked_Convert_To - (RTE (RE_Address), Obj_Tag_Node))); - - -- Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must - -- update it. - - Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr))); - - Insert_Action (Related_Nod, - Make_Object_Declaration (Loc, - Defining_Identifier => Obj_TSD, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Type_Specific_Data_Ptr), Loc), - Expression => - Build_TSD (Loc, New_Occurrence_Of (Tag_Addr, Loc))), - Suppress => All_Checks); - - Insert_Action (Related_Nod, - Make_Object_Declaration (Loc, - Defining_Identifier => Typ_TSD, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Type_Specific_Data_Ptr), Loc), - Expression => - Build_TSD (Loc, - Unchecked_Convert_To (RTE (RE_Address), Typ_Tag_Node))), - Suppress => All_Checks); - - Insert_Action (Related_Nod, - Make_Object_Declaration (Loc, - Defining_Identifier => Index, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), - Expression => - Make_Op_Subtract (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - New_Occurrence_Of (Obj_TSD, Loc)), - Selector_Name => - New_Occurrence_Of - (RTE_Record_Component (RE_Idepth), Loc)), - - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - New_Occurrence_Of (Typ_TSD, Loc)), - Selector_Name => - New_Occurrence_Of - (RTE_Record_Component (RE_Idepth), Loc)))), - Suppress => All_Checks); - - New_Node := - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Ge (Loc, - Left_Opnd => New_Occurrence_Of (Index, Loc), - Right_Opnd => Build_Val (Loc, Uint_0)), - - Right_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Indexed_Component (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - New_Occurrence_Of (Obj_TSD, Loc)), - Selector_Name => - New_Occurrence_Of - (RTE_Record_Component (RE_Tags_Table), Loc)), - Expressions => - New_List (New_Occurrence_Of (Index, Loc))), - - Right_Opnd => Typ_Tag_Node)); - end Build_CW_Membership; - -------------- -- Build_DT -- -------------- diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads --- a/gcc/ada/exp_atag.ads +++ b/gcc/ada/exp_atag.ads @@ -41,24 +41,6 @@ package Exp_Atag is -- timed, asynchronous, and conditional select and append them to Stmts. -- Typ is the tagged type used for dispatching calls. - procedure Build_CW_Membership - (Loc : Source_Ptr; - Obj_Tag_Node : in out Node_Id; - Typ_Tag_Node : Node_Id; - Related_Nod : Node_Id; - New_Node : out Node_Id); - -- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT - -- has a table of ancestors and its inheritance level (Idepth). Obj is in - -- Typ'Class if Typ'Tag is found in the table of ancestors referenced by - -- Obj'Tag. Knowing the level of inheritance of both types, this can be - -- computed in constant time by the formula: - -- - -- Index := TSD (Obj'Tag).Idepth - TSD (Typ'Tag).Idepth; - -- Index >= 0 and then TSD (Obj'Tag).Tags_Table (Index) = Typ'Tag - -- - -- Related_Nod is the node where the implicit declaration of variable Index - -- is inserted. Obj_Tag_Node is relocated. - function Build_Get_Access_Level (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6827,18 +6827,7 @@ package body Exp_Ch4 is -- If the designated type is tagged, do tagged membership -- operation. - -- *** NOTE: we have to check not null before doing the - -- tagged membership test (but maybe that can be done - -- inside Tagged_Membership?). - if Is_Tagged_Type (Typ) then - Rewrite (N, - Make_And_Then (Loc, - Left_Opnd => Relocate_Node (N), - Right_Opnd => - Make_Op_Ne (Loc, - Left_Opnd => Obj, - Right_Opnd => Make_Null (Loc)))); -- No expansion will be performed for VM targets, as -- the VM back ends will handle the membership tests @@ -14969,6 +14958,9 @@ package body Exp_Ch4 is -- usually implemented by looking in the ancestor tables contained in the -- dispatch table pointed by Left_Expr.Tag for Typ'Tag + -- In both cases if Left_Expr is an access type, we first check whether it + -- is null. + -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT -- function IW_Membership which is usually implemented by looking in the -- table of abstract interface types plus the ancestor table contained in @@ -14983,19 +14975,17 @@ package body Exp_Ch4 is Right : constant Node_Id := Right_Opnd (N); Loc : constant Source_Ptr := Sloc (N); - Full_R_Typ : Entity_Id; - Left_Type : Entity_Id; - New_Node : Node_Id; - Right_Type : Entity_Id; - Obj_Tag : Node_Id; + -- Handle entities from the limited view - begin - SCIL_Node := Empty; + Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right)); - -- Handle entities from the limited view + Full_R_Typ : Entity_Id; + Left_Type : Entity_Id := Available_View (Etype (Left)); + Right_Type : Entity_Id := Orig_Right_Type; + Obj_Tag : Node_Id; - Left_Type := Available_View (Etype (Left)); - Right_Type := Available_View (Etype (Right)); + begin + SCIL_Node := Empty; -- In the case where the type is an access type, the test is applied -- using the designated types (needed in Ada 2012 for implicit anonymous @@ -15069,7 +15059,7 @@ package body Exp_Ch4 is or else Is_Interface (Left_Type) then -- Issue error if IW_Membership operation not available in a - -- configurable run time setting. + -- configurable run-time setting. if not RTE_Available (RE_IW_Membership) then Error_Msg_CRT @@ -15092,25 +15082,32 @@ package body Exp_Ch4 is -- Ada 95: Normal case else - Build_CW_Membership (Loc, - Obj_Tag_Node => Obj_Tag, - Typ_Tag_Node => - New_Occurrence_Of ( - Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc), - Related_Nod => N, - New_Node => New_Node); + -- Issue error if CW_Membership operation not available in a + -- configurable run-time setting. + + if not RTE_Available (RE_CW_Membership) then + Error_Msg_CRT + ("dynamic membership test on tagged types", N); + Result := Empty; + return; + end if; + + Result := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc), + Parameter_Associations => New_List ( + Obj_Tag, + New_Occurrence_Of ( + Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), + Loc))); -- Generate the SCIL node for this class-wide membership test. - -- Done here because the previous call to Build_CW_Membership - -- relocates Obj_Tag. if Generate_SCIL then SCIL_Node := Make_SCIL_Membership_Test (Sloc (N)); Set_SCIL_Entity (SCIL_Node, Etype (Right_Type)); Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag); end if; - - Result := New_Node; end if; -- Right_Type is not a class-wide type @@ -15130,6 +15127,29 @@ package body Exp_Ch4 is (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc)); end if; end if; + + -- if Left is an access object then generate test of the form: + -- * if Right_Type excludes null: Left /= null and then ... + -- * if Right_Type includes null: Left = null or else ... + + if Is_Access_Type (Orig_Right_Type) then + if Can_Never_Be_Null (Orig_Right_Type) then + Result := Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Left, + Right_Opnd => Make_Null (Loc)), + Right_Opnd => Result); + + else + Result := Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Left, + Right_Opnd => Make_Null (Loc)), + Right_Opnd => Result); + end if; + end if; end Tagged_Membership; ------------------------------ diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -430,28 +430,21 @@ package body Exp_Intr is -- the tag in the table of ancestor tags. elsif not Is_Interface (Result_Typ) then - declare - Obj_Tag_Node : Node_Id := New_Copy_Tree (Tag_Arg); - CW_Test_Node : Node_Id; - - begin - Build_CW_Membership (Loc, - Obj_Tag_Node => Obj_Tag_Node, - Typ_Tag_Node => - New_Occurrence_Of ( - Node (First_Elmt (Access_Disp_Table ( - Root_Type (Result_Typ)))), Loc), - Related_Nod => N, - New_Node => CW_Test_Node); - - Insert_Action (N, - Make_Implicit_If_Statement (N, - Condition => - Make_Op_Not (Loc, CW_Test_Node), - Then_Statements => - New_List (Make_Raise_Statement (Loc, - New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); - end; + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Not (Loc, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc), + Parameter_Associations => New_List ( + New_Copy_Tree (Tag_Arg), + New_Occurrence_Of ( + Node (First_Elmt (Access_Disp_Table ( + Root_Type (Result_Typ)))), Loc)))), + Then_Statements => + New_List ( + Make_Raise_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); -- Call IW_Membership test if the Result_Type is an abstract interface -- to look for the tag in the table of interface tags. diff --git a/gcc/ada/libgnat/a-tags.adb b/gcc/ada/libgnat/a-tags.adb --- a/gcc/ada/libgnat/a-tags.adb +++ b/gcc/ada/libgnat/a-tags.adb @@ -49,10 +49,6 @@ package body Ada.Tags is -- Local Subprograms -- ----------------------- - function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; - -- Given the tag of an object and the tag associated to a type, return - -- true if Obj is in Typ'Class. - function Get_External_Tag (T : Tag) return System.Address; -- Returns address of a null terminated string containing the external name @@ -82,7 +78,6 @@ package body Ada.Tags is -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the -- address of the record containing the Select Specific Data in T's TSD. - pragma Inline_Always (CW_Membership); pragma Inline_Always (Get_External_Tag); pragma Inline_Always (Is_Primary_DT); pragma Inline_Always (OSD); diff --git a/gcc/ada/libgnat/a-tags.ads b/gcc/ada/libgnat/a-tags.ads --- a/gcc/ada/libgnat/a-tags.ads +++ b/gcc/ada/libgnat/a-tags.ads @@ -501,6 +501,10 @@ private -- dispatch table, return the tagged kind of a type in the context of -- concurrency and limitedness. + function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; + -- Given the tag of an object and the tag associated to a type, return + -- true if Obj is in Typ'Class. + function IW_Membership (This : System.Address; T : Tag) return Boolean; -- Ada 2005 (AI-251): General routine that checks if a given object -- implements a tagged type. Its common usage is to check if Obj is in diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -512,6 +512,7 @@ package Rtsfind is RE_Check_Interface_Conversion, -- Ada.Tags RE_Check_TSD, -- Ada.Tags RE_Cstring_Ptr, -- Ada.Tags + RE_CW_Membership, -- Ada.Tags RE_Descendant_Tag, -- Ada.Tags RE_Dispatch_Table, -- Ada.Tags RE_Dispatch_Table_Wrapper, -- Ada.Tags @@ -1798,6 +1799,7 @@ package Rtsfind is RE_Check_Interface_Conversion => Ada_Tags, RE_Check_TSD => Ada_Tags, RE_Cstring_Ptr => Ada_Tags, + RE_CW_Membership => Ada_Tags, RE_Descendant_Tag => Ada_Tags, RE_Dispatch_Table => Ada_Tags, RE_Dispatch_Table_Wrapper => Ada_Tags,