[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.

diff --git a/gcc/ada/libgnat/a-tags.adb b/gcc/ada/libgnat/a-tags.adb
index 798780a4c1a19c166792de53b13f1b50009cc554..7138f762239b0bf339180646c145b7341b2e3116 100644 (file)
--- 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 fb386c373f07fdc1e568a6a656f2e0a4b0a5302a..203f7ca95d4c4b19e3860fa6b3659a560aafbaae 100644 (file)
--- 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 (file)
index 75470e3..0000000
--- 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" } }