procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Performance of CW_Membership

Browse source 
gcc/ada/

	* libgnat/a-tags.ads, libgnat/a-tags.adb (CW_Membership): Move
	to spec to allow inlining.

gcc/testsuite/

	* gnat.dg/debug15.adb: Remove fragile testcase.
This commit is contained in:
Arnaud Charlet 2020-11-19 05:42:03 -05:00 • committed by Pierre-Marie de Rodat
parent 68dd664912
commit 6a6926635c
3 changed files with 46 additions and 71 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

44
gcc/ada/libgnat/a-tags.adb
View file

@ -30,7 +30,6 @@
------------------------------------------------------------------------------
with Ada.Exceptions;
with Ada.Unchecked_Conversion;
with System.HTable;
with System.Storage_Elements; use System.Storage_Elements;
@ -96,12 +95,6 @@ package body Ada.Tags is
function To_Tag is
new Unchecked_Conversion (Integer_Address, Tag);
function To_Addr_Ptr is
new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
function To_Address is
new Ada.Unchecked_Conversion (Tag, System.Address);
function To_Dispatch_Table_Ptr is
new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr);
@ -114,9 +107,6 @@ package body Ada.Tags is
function To_Tag_Ptr is
new Ada.Unchecked_Conversion (System.Address, Tag_Ptr);
function To_Type_Specific_Data_Ptr is
new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
-------------------------------
-- Inline_Always Subprograms --
-------------------------------
@ -125,40 +115,6 @@ package body Ada.Tags is
-- avoid defeating the frontend inlining mechanism and thus ensure the
-- generation of their correct debug info.
-------------------
-- CW_Membership --
-------------------
-- Canonical implementation of Classwide Membership corresponding to:
-- Obj in Typ'Class
-- Each dispatch table contains a reference to a table of ancestors (stored
-- in the first part of the Tags_Table) and a count of the level of
-- inheritance "Idepth".
-- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
-- contained in the dispatch table referenced by Obj'Tag . Knowing the
-- level of inheritance of both types, this can be computed in constant
-- time by the formula:
-- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
-- = Typ'tag
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
Obj_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size);
Typ_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size);
Obj_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all);
Typ_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all);
Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth;
begin
return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag;
end CW_Membership;
----------------------
-- Get_External_Tag --
----------------------

50
gcc/ada/libgnat/a-tags.ads
View file

@ -65,6 +65,7 @@
-- length depends on the number of interfaces covered by a tagged type.
with System.Storage_Elements;
with Ada.Unchecked_Conversion;
package Ada.Tags is
pragma Preelaborate;
@ -501,10 +502,6 @@ 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
@ -623,4 +620,49 @@ private
-- This type is used by the frontend to generate the code that handles
-- dispatch table slots of types declared at the local level.
-------------------
-- CW_Membership --
-------------------
function To_Address is
new Ada.Unchecked_Conversion (Tag, System.Address);
function To_Addr_Ptr is
new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
function To_Type_Specific_Data_Ptr is
new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
-- Canonical implementation of Classwide Membership corresponding to:
-- Obj in Typ'Class
-- Each dispatch table contains a reference to a table of ancestors (stored
-- in the first part of the Tags_Table) and a count of the level of
-- inheritance "Idepth".
-- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
-- contained in the dispatch table referenced by Obj'Tag . Knowing the
-- level of inheritance of both types, this can be computed in constant
-- time by the formula:
-- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
-- = Typ'tag
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
(declare
Obj_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size);
Typ_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size);
Obj_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all);
Typ_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all);
Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth;
begin
Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag);
-- Given the tag of an object and the tag associated to a type, return
-- true if Obj is in Typ'Class.
end Ada.Tags;

23
gcc/testsuite/gnat.dg/debug15.adb
View file

@ -1,23 +0,0 @@
-- { dg-do compile }
-- { dg-options "-g1" }
procedure Debug15 is
type Shape is abstract tagged record
S : Integer;
end record;
type Rectangle is new Shape with record
R : Integer;
end record;
X : Integer;
R: Rectangle := (1, 2);
S: Shape'Class := R;
begin
X := 12;
end;
-- { dg-final { scan-assembler-not "loc 2" } }