From 6a6926635c36e0ef2598b5399afdbfc2dbd4bf1f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 19 Nov 2020 05:42:03 -0500 Subject: [PATCH] [Ada] Performance of CW_Membership 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. --- gcc/ada/libgnat/a-tags.adb | 44 --------------------------- gcc/ada/libgnat/a-tags.ads | 50 ++++++++++++++++++++++++++++--- gcc/testsuite/gnat.dg/debug15.adb | 23 -------------- 3 files changed, 46 insertions(+), 71 deletions(-) delete mode 100644 gcc/testsuite/gnat.dg/debug15.adb diff --git a/gcc/ada/libgnat/a-tags.adb b/gcc/ada/libgnat/a-tags.adb index 798780a4c1a..7138f762239 100644 --- a/gcc/ada/libgnat/a-tags.adb +++ b/gcc/ada/libgnat/a-tags.adb @@ -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 -- ---------------------- diff --git a/gcc/ada/libgnat/a-tags.ads b/gcc/ada/libgnat/a-tags.ads index fb386c373f0..203f7ca95d4 100644 --- a/gcc/ada/libgnat/a-tags.ads +++ b/gcc/ada/libgnat/a-tags.ads @@ -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; diff --git a/gcc/testsuite/gnat.dg/debug15.adb b/gcc/testsuite/gnat.dg/debug15.adb deleted file mode 100644 index 75470e3c319..00000000000 --- a/gcc/testsuite/gnat.dg/debug15.adb +++ /dev/null @@ -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" } } -- 2.30.2