From patchwork Tue Aug 13 08:31:56 2019 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: 1146104 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-506760-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="s0/qQQKM"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4675Ys2S0Xz9sND for ; Tue, 13 Aug 2019 18:32:33 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=Azy1zJWXcZSneWmSjN0DMjfSMkw3XTM/ecAa9PkZ2dalHWkOOi yLgPrYV+0keAfAhiURS8t/LoIdwvM3Al5Gt6UqqcCZlTIzEv1zDT+nNyqF/CsgIm u5BjjnSLqGRnVMGcDqSUjvt3kA3JCSgA59pPzt8G3OrhFkk0tC/adlCSw= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=f00+w+LgfylhtXNl/bzojzcUI0A=; b=s0/qQQKMtImYC31UM/Wf QWvaNVqwp7HKp68ZADl65j/cB0Un8Bovt/447Wm0QUS+Yg5bKxa899ei17FTf5cM r84ULuTwCGcBCaAXCyB9ESEZHvKZ8uF5NC1L+mYe4xXPzncT4yNP6LiEPqN+JkVo ar1QwKBE/ERWd0kP/LU3tv0= Received: (qmail 109278 invoked by alias); 13 Aug 2019 08:32:00 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 109183 invoked by uid 89); 13 Aug 2019 08:32:00 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.9 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=monitor, Monitor X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 13 Aug 2019 08:31:58 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id C2193560EF; Tue, 13 Aug 2019 04:31:56 -0400 (EDT) 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 IPIoWktbKFwn; Tue, 13 Aug 2019 04:31:56 -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 AE24A560EA; Tue, 13 Aug 2019 04:31:56 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id ACE4C6B4; Tue, 13 Aug 2019 04:31:56 -0400 (EDT) Date: Tue, 13 Aug 2019 04:31:56 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Wrong initialization of Offset_To_Top in secondary DT Message-ID: <20190813083156.GA38496@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes The compiler does not initialize well the runtime information required to perform at runtime interface conversions on derivations of tagged types that implement interfaces and have variable size components. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-08-13 Javier Miranda gcc/ada/ * exp_disp.adb (Make_Secondary_DT): Handle record type derivations that have interface components located at fixed positions and interface components located at variable offset. The offset of components located at fixed positions is computed using the dummy object (similar to the case where all the interface components are located at fixed positions). (Make_DT): Build the dummy object for all tagged types that implement interface types (that is, build it also for types with variable size components), and use the dummy object to compute the offset of all tag components located at fixed positions when initializing the Interface_Table object. gcc/testsuite/ * gnat.dg/tag2.adb, gnat.dg/tag2_pkg.ads: New testcase. --- gcc/ada/exp_disp.adb +++ gcc/ada/exp_disp.adb @@ -3764,7 +3764,7 @@ package body Exp_Disp is Dummy_Object : Entity_Id := Empty; -- Extra nonexistent object of type Typ internally used to compute the -- offset to the components that reference secondary dispatch tables. - -- Used to statically allocate secondary dispatch tables. + -- Used to compute the offset of components located at fixed position. procedure Check_Premature_Freezing (Subp : Entity_Id; @@ -4191,14 +4191,16 @@ package body Exp_Disp is Prefix => New_Occurrence_Of (Predef_Prims, Loc), Attribute_Name => Name_Address)); - -- If the location of the component that references this secondary - -- dispatch table is variable then we have not declared the internal - -- dummy object; the value of Offset_To_Top will be set by the init - -- subprogram. + -- Interface component located at variable offset; the value of + -- Offset_To_Top will be set by the init subprogram. - if No (Dummy_Object) then + if No (Dummy_Object) + or else Is_Variable_Size_Record (Etype (Scope (Iface_Comp))) + then Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); + -- Interface component located at fixed offset + else Append_To (DT_Aggr_List, Make_Op_Minus (Loc, @@ -4444,7 +4446,7 @@ package body Exp_Disp is Make_Object_Declaration (Loc, Defining_Identifier => Iface_DT, Aliased_Present => True, - Constant_Present => Present (Dummy_Object), + Constant_Present => Building_Static_Secondary_DT (Typ), Object_Definition => Make_Subtype_Indication (Loc, @@ -4723,9 +4725,10 @@ package body Exp_Disp is end; end if; - if Building_Static_Secondary_DT (Typ) then + if not Is_Interface (Typ) and then Has_Interfaces (Typ) then declare Cannot_Have_Null_Disc : Boolean := False; + Dummy_Object_Typ : constant Entity_Id := Typ; Name_Dummy_Object : constant Name_Id := New_External_Name (Tname, 'P', Suffix_Index => -1); @@ -4754,19 +4757,20 @@ package body Exp_Disp is Set_Is_Internal (Dummy_Object); - if not Has_Discriminants (Typ) then + if not Has_Discriminants (Dummy_Object_Typ) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Dummy_Object, Constant_Present => True, - Object_Definition => New_Occurrence_Of (Typ, Loc))); + Object_Definition => New_Occurrence_Of + (Dummy_Object_Typ, Loc))); else declare Constr_List : constant List_Id := New_List; Discrim : Node_Id; begin - Discrim := First_Discriminant (Typ); + Discrim := First_Discriminant (Dummy_Object_Typ); while Present (Discrim) loop if Is_Discrete_Type (Etype (Discrim)) then Append_To (Constr_List, @@ -4792,7 +4796,8 @@ package body Exp_Disp is Constant_Present => True, Object_Definition => Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Subtype_Mark => + New_Occurrence_Of (Dummy_Object_Typ, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constr_List)))); @@ -5500,19 +5505,23 @@ package body Exp_Disp is declare TSD_Ifaces_List : constant List_Id := New_List; Elmt : Elmt_Id; - Ifaces_List : Elist_Id := No_Elist; - Ifaces_Comp_List : Elist_Id := No_Elist; - Ifaces_Tag_List : Elist_Id; Offset_To_Top : Node_Id; Sec_DT_Tag : Node_Id; + Dummy_Object_Ifaces_List : Elist_Id := No_Elist; + Dummy_Object_Ifaces_Comp_List : Elist_Id := No_Elist; + Dummy_Object_Ifaces_Tag_List : Elist_Id := No_Elist; + -- Interfaces information of the dummy object + begin -- Collect interfaces information if we need to compute the -- offset to the top using the dummy object. if Present (Dummy_Object) then Collect_Interfaces_Info (Typ, - Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); + Ifaces_List => Dummy_Object_Ifaces_List, + Components_List => Dummy_Object_Ifaces_Comp_List, + Tags_List => Dummy_Object_Ifaces_Tag_List); end if; AI := First_Elmt (Typ_Ifaces); @@ -5550,8 +5559,8 @@ package body Exp_Disp is (Node (Next_Elmt (Next_Elmt (Elmt))), Loc); end if; - -- For static dispatch tables compute Offset_To_Top using - -- the dummy object. + -- Use the dummy object to compute Offset_To_Top of + -- components located at fixed position. if Present (Dummy_Object) then declare @@ -5561,8 +5570,10 @@ package body Exp_Disp is Iface_Elmt : Elmt_Id; begin - Iface_Elmt := First_Elmt (Ifaces_List); - Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); + Iface_Elmt := + First_Elmt (Dummy_Object_Ifaces_List); + Iface_Comp_Elmt := + First_Elmt (Dummy_Object_Ifaces_Comp_List); while Present (Iface_Elmt) loop if Node (Iface_Elmt) = Iface then @@ -5576,16 +5587,22 @@ package body Exp_Disp is pragma Assert (Present (Iface_Comp)); - Offset_To_Top := - Make_Op_Minus (Loc, - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Dummy_Object, Loc), - Selector_Name => - New_Occurrence_Of (Iface_Comp, Loc)), - Attribute_Name => Name_Position)); + if not + Is_Variable_Size_Record (Etype (Scope (Iface_Comp))) + then + Offset_To_Top := + Make_Op_Minus (Loc, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Dummy_Object, Loc), + Selector_Name => + New_Occurrence_Of (Iface_Comp, Loc)), + Attribute_Name => Name_Position)); + else + Offset_To_Top := Make_Integer_Literal (Loc, 0); + end if; end; else Offset_To_Top := Make_Integer_Literal (Loc, 0); @@ -5634,7 +5651,7 @@ package body Exp_Disp is Make_Object_Declaration (Loc, Defining_Identifier => ITable, Aliased_Present => True, - Constant_Present => Present (Dummy_Object), + Constant_Present => Building_Static_Secondary_DT (Typ), Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/tag2.adb @@ -0,0 +1,20 @@ +-- { dg-do run } + +with Ada.Tags; use Ada.Tags; +with Tag2_Pkg; use Tag2_Pkg; + +procedure Tag2 is + + procedure Do_Add_Monitor (Monitor : in out Synchronous_Monitor) is + Name : constant String := + Expanded_Name (Monitor_Interface'Class (Monitor)'Tag); + begin + if Name /= "TAG2_PKG.VIRTUAL_INTEGER_REGISTER_REFRESHER" then + raise Program_Error; + end if; + end; + + Obj : Virtual_Integer_Register_Refresher (20); +begin + Do_Add_Monitor (Synchronous_Monitor (Obj)); +end; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/tag2_pkg.ads @@ -0,0 +1,16 @@ +package Tag2_Pkg is + type Monitor_Interface is interface; + + type Root is abstract tagged null record; + + type Monitor_Type is abstract new Root + and Monitor_Interface with null record; + + type Synchronous_Monitor (Size : Positive) is new Monitor_Type with + record + Queue : String (1 .. Size); + end record; + + type Virtual_Integer_Register_Refresher (Size : Positive) is + new Synchronous_Monitor (Size) with null record; +end;