From 7225a4797180b6dc515760b0c123001cda2b66a2 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Tue, 13 Aug 2019 08:06:34 +0000 Subject: [PATCH] [Ada] Wrong initialization of Offset_To_Top in secondary DT 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. 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. From-SVN: r274335 --- gcc/ada/ChangeLog | 14 ++++++ gcc/ada/exp_disp.adb | 79 ++++++++++++++++++------------ gcc/testsuite/ChangeLog | 4 ++ gcc/testsuite/gnat.dg/tag2.adb | 20 ++++++++ gcc/testsuite/gnat.dg/tag2_pkg.ads | 16 ++++++ 5 files changed, 102 insertions(+), 31 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/tag2.adb create mode 100644 gcc/testsuite/gnat.dg/tag2_pkg.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1cc1ef2850d..0c34ee8663c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2019-08-13 Javier Miranda + + * 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. + 2019-08-13 Justin Squirek * gnatcmd.adb (GNATCmd): Add constant for new compiler switch diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 4fae37c491a..8399c4c80da 100644 --- a/gcc/ada/exp_disp.adb +++ b/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 => diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 839772170de..265d991154f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-08-13 Javier Miranda + + * gnat.dg/tag2.adb, gnat.dg/tag2_pkg.ads: New testcase. + 2019-08-13 Martin Liska * gcc.dg/tree-prof/ic-misattribution-1.c: Use -fdump-ipa-profile-node. diff --git a/gcc/testsuite/gnat.dg/tag2.adb b/gcc/testsuite/gnat.dg/tag2.adb new file mode 100644 index 00000000000..77e4842ae97 --- /dev/null +++ b/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; diff --git a/gcc/testsuite/gnat.dg/tag2_pkg.ads b/gcc/testsuite/gnat.dg/tag2_pkg.ads new file mode 100644 index 00000000000..3fd5923fbf6 --- /dev/null +++ b/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;