@@ -611,6 +611,9 @@ GNATRTL_NONTASKING_OBJS= \
s-geveop$(objext) \
s-gloloc$(objext) \
s-htable$(objext) \
+ s-imad32$(objext) \
+ s-imad64$(objext) \
+ s-imagea$(objext) \
s-imageb$(objext) \
s-imaged$(objext) \
s-imagef$(objext) \
@@ -36,6 +36,7 @@ with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
with Sem_Aux; use Sem_Aux;
with Sem_Disp; use Sem_Disp;
with Sem_Util; use Sem_Util;
@@ -776,19 +777,45 @@ package body Exp_Atag is
function Build_Set_Size_Function
(Loc : Source_Ptr;
- Tag_Node : Node_Id;
- Size_Func : Entity_Id) return Node_Id is
+ Typ : Entity_Id;
+ Size_Func : Entity_Id) return Node_Id
+ is
+ F_Nod : constant Node_Id := Freeze_Node (Typ);
+
+ Act : Node_Id;
+
begin
pragma Assert (Chars (Size_Func) = Name_uSize
- and then RTE_Record_Component_Available (RE_Size_Func));
+ and then RTE_Record_Component_Available (RE_Size_Func)
+ and then Present (F_Nod));
+
+ -- Find the declaration of the TSD object in the freeze actions
+
+ Act := First (Actions (F_Nod));
+ while Present (Act) loop
+ if Nkind (Act) = N_Object_Declaration
+ and then Nkind (Object_Definition (Act)) = N_Subtype_Indication
+ and then Is_Entity_Name (Subtype_Mark (Object_Definition (Act)))
+ and then Is_RTE (Entity (Subtype_Mark (Object_Definition (Act))),
+ RE_Type_Specific_Data)
+ then
+ exit;
+ end if;
+
+ Next (Act);
+ end loop;
+
+ pragma Assert (Present (Act));
+
+ -- Generate:
+ -- TSD.Size_Func := Size_Ptr!(Size_Func'Unrestricted_Access);
+
return
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix =>
- Make_Explicit_Dereference (Loc,
- Build_TSD (Loc,
- Unchecked_Convert_To (RTE (RE_Address), Tag_Node))),
+ Prefix =>
+ New_Occurrence_Of (Defining_Identifier (Act), Loc),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Size_Func), Loc)),
@@ -162,9 +162,9 @@ package Exp_Atag is
function Build_Set_Size_Function
(Loc : Source_Ptr;
- Tag_Node : Node_Id;
+ Typ : Entity_Id;
Size_Func : Entity_Id) return Node_Id;
- -- Build code that saves in the TSD the address of the function
+ -- Build code that saves in the TSD of Typ the address of the function
-- calculating _size of the object.
function Build_Set_Static_Offset_To_Top
@@ -70,6 +70,7 @@ with Stringt; use Stringt;
with Strub; use Strub;
with SCIL_LL; use SCIL_LL;
with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
package body Exp_Disp is
@@ -5217,8 +5218,10 @@ package body Exp_Disp is
Chars => New_External_Name (Tname, 'A'));
Full_Name : constant String_Id :=
Fully_Qualified_Name_String (First_Subtype (Typ));
- Str1_Id : String_Id;
- Str2_Id : String_Id;
+
+ Address_Image : RE_Id;
+ Str1_Id : String_Id;
+ Str2_Id : String_Id;
begin
-- Generate:
@@ -5240,7 +5243,17 @@ package body Exp_Disp is
-- Exname : constant String :=
-- Str1 & Address_Image (Tag) & Str2;
- if RTE_Available (RE_Address_Image) then
+ -- We use Address_Image64 for Morello because Integer_Address
+ -- is 64-bit large even though Address is 128-bit large.
+
+ case System_Address_Size is
+ when 32 => Address_Image := RE_Address_Image32;
+ when 64 => Address_Image := RE_Address_Image64;
+ when 128 => Address_Image := RE_Address_Image64;
+ when others => raise Program_Error;
+ end case;
+
+ if RTE_Available (Address_Image) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Exname,
@@ -5256,7 +5269,7 @@ package body Exp_Disp is
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
- (RTE (RE_Address_Image), Loc),
+ (RTE (Address_Image), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address),
New_Occurrence_Of (DT_Ptr, Loc)))),
@@ -7565,11 +7578,7 @@ package body Exp_Disp is
if Chars (Prim) = Name_uSize
and then RTE_Record_Component_Available (RE_Size_Func)
then
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
- Append_To (L,
- Build_Set_Size_Function (Loc,
- Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
- Size_Func => Prim));
+ Append_To (L, Build_Set_Size_Function (Loc, Tag_Typ, Prim));
end if;
else
@@ -528,6 +528,8 @@ GNAT_ADA_OBJS+= \
ada/libgnat/s-excmac.o \
ada/libgnat/s-exctab.o \
ada/libgnat/s-htable.o \
+ ada/libgnat/s-imad32.o \
+ ada/libgnat/s-imad64.o \
ada/libgnat/s-imgint.o \
ada/libgnat/s-mastop.o \
ada/libgnat/s-memory.o \
@@ -260,6 +260,7 @@ private
type Prim_Ptr is access procedure;
type Address_Array is array (Positive range <>) of Prim_Ptr;
+ pragma Suppress_Initialization (Address_Array);
subtype Dispatch_Table is Address_Array (1 .. 1);
-- Used by GDB to identify the _tags and traverse the run-time structure
@@ -29,44 +29,18 @@
-- --
------------------------------------------------------------------------------
-with Ada.Unchecked_Conversion;
+with System.Img_Address_32;
+with System.Img_Address_64;
function System.Address_Image (A : Address) return String is
-
- Result : String (1 .. 2 * Address'Size / Storage_Unit);
-
- type Byte is mod 2 ** 8;
- for Byte'Size use 8;
-
- Hexdigs :
- constant array (Byte range 0 .. 15) of Character := "0123456789ABCDEF";
-
- type Bytes is array (1 .. Address'Size / Storage_Unit) of Byte;
- for Bytes'Size use Address'Size;
-
- function To_Bytes is new Ada.Unchecked_Conversion (Address, Bytes);
-
- Byte_Sequence : constant Bytes := To_Bytes (A);
-
- LE : constant := Standard'Default_Bit_Order;
- BE : constant := 1 - LE;
- -- Set to 1/0 for True/False for Little-Endian/Big-Endian
-
- Start : constant Natural := BE * (1) + LE * (Bytes'Length);
- Incr : constant Integer := BE * (1) + LE * (-1);
- -- Start and increment for accessing characters of address string
-
- Ptr : Natural;
- -- Scan address string
-
begin
- Ptr := Start;
- for N in Bytes'Range loop
- Result (2 * N - 1) := Hexdigs (Byte_Sequence (Ptr) / 16);
- Result (2 * N) := Hexdigs (Byte_Sequence (Ptr) mod 16);
- Ptr := Ptr + Incr;
- end loop;
-
- return Result;
-
+ -- We use Address_Image64 for Morello because Integer_Address is 64-bit
+ -- large even though Address is 128-bit large.
+
+ case Address'Size is
+ when 32 => return String (System.Img_Address_32.Address_Image32 (A));
+ when 64 => return String (System.Img_Address_64.Address_Image64 (A));
+ when 128 => return String (System.Img_Address_64.Address_Image64 (A));
+ when others => raise Program_Error;
+ end case;
end System.Address_Image;
new file mode 100644
@@ -0,0 +1,43 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ A D D R E S S _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2024, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces;
+with System.Image_A;
+
+package System.Img_Address_32 is
+ pragma Pure;
+
+ package Impl is new Image_A (Interfaces.Unsigned_32);
+
+ function Address_Image32 (A : Address) return Impl.Address_String
+ renames Impl.Address_Image;
+
+end System.Img_Address_32;
new file mode 100644
@@ -0,0 +1,43 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ A D D R E S S _ 6 4 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2024, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces;
+with System.Image_A;
+
+package System.Img_Address_64 is
+ pragma Pure;
+
+ package Impl is new Image_A (Interfaces.Unsigned_64);
+
+ function Address_Image64 (A : Address) return Impl.Address_String
+ renames Impl.Address_Image;
+
+end System.Img_Address_64;
new file mode 100644
@@ -0,0 +1,80 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ A --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2024, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Conversion;
+
+with System.Storage_Elements; use System.Storage_Elements;
+
+package body System.Image_A is
+
+ -------------------
+ -- Address_Image --
+ -------------------
+
+ function Address_Image (A : Address) return Address_String is
+ Result : Address_String;
+
+ type Byte is mod 2 ** 8;
+ for Byte'Size use 8;
+
+ Hexdigs :
+ constant array (Byte range 0 .. 15) of Character := "0123456789ABCDEF";
+
+ type Bytes is array (1 .. Uns'Size / Storage_Unit) of Byte;
+
+ function To_Bytes is new Ada.Unchecked_Conversion (Uns, Bytes);
+
+ Byte_Sequence : constant Bytes := To_Bytes (Uns (Integer_Address (A)));
+
+ LE : constant := Standard'Default_Bit_Order;
+ BE : constant := 1 - LE;
+ -- Set to 1/0 for True/False for Little-Endian/Big-Endian
+
+ Start : constant Natural := BE * (1) + LE * (Bytes'Length);
+ Incr : constant Integer := BE * (1) + LE * (-1);
+ -- Start and increment for accessing characters of address string
+
+ Ptr : Natural;
+ -- Scan address string
+
+ begin
+ Ptr := Start;
+
+ for N in Bytes'Range loop
+ Result (2 * N - 1) := Hexdigs (Byte_Sequence (Ptr) / 16);
+ Result (2 * N) := Hexdigs (Byte_Sequence (Ptr) mod 16);
+ Ptr := Ptr + Incr;
+ end loop;
+
+ return Result;
+ end Address_Image;
+
+end System.Image_A;
new file mode 100644
@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ A --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2024, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+generic
+
+ type Uns is mod <>;
+
+package System.Image_A is
+ pragma Pure;
+
+ subtype Address_String is String (1 .. 2 * Uns'Size / Storage_Unit);
+
+ function Address_Image (A : Address) return Address_String;
+ -- Return a string made up of hexadecimal digits with upper case letters
+ -- and without prefix representing the (lower part of) address A.
+
+end System.Image_A;
@@ -605,7 +605,7 @@ package body Rtsfind is
range Interfaces_C_Strings .. Interfaces_C_Strings;
subtype System_Descendant is RTU_Id
- range System_Address_Image .. System_Tasking_Stages;
+ range System_Address_To_Access_Conversions .. System_Tasking_Stages;
subtype System_Atomic_Operations_Descendant is System_Descendant
range System_Atomic_Operations_Test_And_Set ..
@@ -199,7 +199,6 @@ package Rtsfind is
-- Children of System
- System_Address_Image,
System_Address_To_Access_Conversions,
System_Arith_64,
System_Arith_128,
@@ -263,6 +262,8 @@ package Rtsfind is
System_Fore_Fixed_64,
System_Fore_Fixed_128,
System_Fore_Real,
+ System_Img_Address_32,
+ System_Img_Address_64,
System_Img_Bool,
System_Img_Char,
System_Img_Decimal_32,
@@ -756,7 +757,8 @@ package Rtsfind is
RE_Null_Address, -- System
RE_Priority, -- System
- RE_Address_Image, -- System.Address_Image
+ RE_Address_Image32, -- System.Img_Address_32
+ RE_Address_Image64, -- System.Img_Address_64
RE_Add_With_Ovflo_Check64, -- System.Arith_64
RE_Double_Divide64, -- System.Arith_64
@@ -2401,7 +2403,8 @@ package Rtsfind is
RE_Null_Address => System,
RE_Priority => System,
- RE_Address_Image => System_Address_Image,
+ RE_Address_Image32 => System_Img_Address_32,
+ RE_Address_Image64 => System_Img_Address_64,
RE_Add_With_Ovflo_Check64 => System_Arith_64,
RE_Double_Divide64 => System_Arith_64,
From: Eric Botcazou <ebotcazou@adacore.com> This set of changes is aimed at streamlining the code generated for the elaboration of local tagged types. The dispatch tables and other related data structures are built dynamically on the stack for them and a few of the patterns used for this turn out to be problematic for the optimizer: 1. the array of primitives in the dispatch table is default-initialized to null values by calling the initialization routine of an unconstrained array type, and then immediately assigned an aggregate made up of the same null values. 2. the external tag is initialized by means of a dynamic concatenation involving the secondary stack, but all the elements have a fixed size. 3. the _size primitive is saved in the TSD by means of the dereference of the address of the TSD that was previously saved in the dispatch table. gcc/ada/ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-imad32$(objext), s-imad64$(objext) and s-imagea$(objext). * exp_atag.ads (Build_Set_Size_Function): Replace Tag_Node parameter with Typ parameter. * exp_atag.adb: Add clauses for Sinfo.Utils. (Build_Set_Size_Function): Retrieve the TSD object statically. * exp_disp.adb: Add clauses for Ttypes. (Make_DT): Call Address_Image{32,64] instead of Address_Image. (Register_Primitive): Pass Tag_Typ to Build_Set_Size_Function. * rtsfind.ads (RTU_Id): Remove System_Address_Image and add System_Img_Address_{32;64}. (RE_Id): Remove entry for RE_Address_Image and add entries for RE_Address_Image{32,64}. * rtsfind.adb (System_Descendant): Adjust to above changes. * libgnat/a-tags.ads (Address_Array): Suppress initialization. * libgnat/s-addima.adb (System.Address_Image): Call the appropriate routine based on the address size. * libgnat/s-imad32.ads: New file. * libgnat/s-imad64.ads: Likewise. * libgnat/s-imagea.ads: Likewise. * libgnat/s-imagea.adb: Likewise. * gcc-interface/Make-lang.in (GNAT_ADA_OBJS) [$(STAGE1)=False]: Add ada/libgnat/s-imad32.o and ada/libgnat/s-imad64.o. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/Makefile.rtl | 3 ++ gcc/ada/exp_atag.adb | 41 ++++++++++++--- gcc/ada/exp_atag.ads | 4 +- gcc/ada/exp_disp.adb | 27 ++++++---- gcc/ada/gcc-interface/Make-lang.in | 2 + gcc/ada/libgnat/a-tags.ads | 1 + gcc/ada/libgnat/s-addima.adb | 48 ++++-------------- gcc/ada/libgnat/s-imad32.ads | 43 ++++++++++++++++ gcc/ada/libgnat/s-imad64.ads | 43 ++++++++++++++++ gcc/ada/libgnat/s-imagea.adb | 80 ++++++++++++++++++++++++++++++ gcc/ada/libgnat/s-imagea.ads | 45 +++++++++++++++++ gcc/ada/rtsfind.adb | 2 +- gcc/ada/rtsfind.ads | 9 ++-- 13 files changed, 289 insertions(+), 59 deletions(-) create mode 100644 gcc/ada/libgnat/s-imad32.ads create mode 100644 gcc/ada/libgnat/s-imad64.ads create mode 100644 gcc/ada/libgnat/s-imagea.adb create mode 100644 gcc/ada/libgnat/s-imagea.ads