From patchwork Thu Jun 13 13:33:17 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1947404 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=L3m0pIMY; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4W0Nkt383jz1ydW for ; Thu, 13 Jun 2024 23:37:42 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id ABD723882651 for ; Thu, 13 Jun 2024 13:37:40 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32a.google.com (mail-wm1-x32a.google.com [IPv6:2a00:1450:4864:20::32a]) by sourceware.org (Postfix) with ESMTPS id 1D9443882174 for ; Thu, 13 Jun 2024 13:34:01 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 1D9443882174 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 1D9443882174 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::32a ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1718285646; cv=none; b=oDXQqkkSqOnpwHYxdvXacT6MqQxLWg6XWf6AenJZu0ur80s8hcCOFtJv8b9fxi9rwa517qYJJrKhQcGF9McgV5fF+3X5zsXS6dwKTR0VL60U+RBPpHhbHDndUq+RITo+56pabS+kXRw96H4RGmwhwCPZN8A8rqAnYvPxm8nZ/AY= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1718285646; c=relaxed/simple; bh=YVNH5XggvUTxe05sW2N2ZupDxpxc5ZSdlVT/OUB98GY=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=Z9CsJxalGlyYsbr8Wjz4deMrNF1d4jHP3uMuxuLuAF/JuewamVostaL5nVM/FDfMF8wbY50WPl/DLKLDp4qEVgITygtuRYKmG3HGlQx9iVVf2JsacGkyhEJIqj5u2c2oEU+c+7C3NjHc4hbo4Dvh+RZ7zD+vZAm1vDiyo0VSZxc= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32a.google.com with SMTP id 5b1f17b1804b1-42179dafd6bso13667765e9.0 for ; Thu, 13 Jun 2024 06:34:01 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1718285640; x=1718890440; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=HuyZESIwWwUNBrYZgxpmpXUHBjmM36R04GhkMygT1CE=; b=L3m0pIMY4mMRi6X0vGHd3h4P5vVZ51i6KmOeb0hZvD6qiLfreyWXgM6qWanIQu3XJA Bx6zq6sPdPtpUX4Ujtm8gs0AWjn1tNtLNyXHbzKAYAVDL2z9mlXoLm2Ls7KpNVR7lf/g rCzTMQ4C25D1xglTVxdw6W4A2g9o4zGZ72uupxDx5IcEtVS7AHHz7ak+A5Qqwx9W30c4 dXnAtDDJf8yvppBZaex8bkB7NUg6OeKrJ6/y+p8oVoENr00APdjIWbGatQAIeBgvqI4D Gm6o8IFxgmIkqgNfgFaSXCHObOh5G3Ogd79hjRvXTOWHDbZksiIghDzKGV9PmjRF19iN ciVw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1718285640; x=1718890440; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=HuyZESIwWwUNBrYZgxpmpXUHBjmM36R04GhkMygT1CE=; b=KonmOdV8h1L4eBQ8S3f/jlxNtACZmwonyGcfzrNyoZEGbAFFbg4KIIoBLa6iqJvQVn 5kcQt2qwBIuZ/eUm16NjIfoOAUgfUi61tyXDY8t1ylwwOvVAbzu/TVpwgJV+XOMqmmux 8NG9hoZ14RSzoqVk1INbjubQGpRof3ZUBU4JBn6leDBMHu+DfNhatbeV6aoh1Hd6lRtR +1OJFSs12bcHussRJXfsEfy6kyUua9L+A/7H+I6A3c45C4kfQ7QcX86sjMLLudsSvb0Z q092uvncA7PrgrjwxvL4HlRndO4cBmkIoJ14+/hTKLba/S83eohcCioqWgsc5ICw7yw4 6QUA== X-Gm-Message-State: AOJu0Yx7RjUEGvk6BFW2MNcLY8tFs81KXXc9ZJBPgJKYTK927PGzjdbs LoabXanuAT4asJcQHELg44/prUCvsTFrfhY1Zo6VLCY5ymZA7XYUBIETwoJomjfxmvsCvOPPaX4 = X-Google-Smtp-Source: AGHT+IE9wraZcKvBkVLmPfxjXs2R6RrIaqOqnzhG0SPwWlqFNFWsJLyepRtJGSs4+c07eS/og3TTQg== X-Received: by 2002:a05:600c:45cd:b0:421:b906:8088 with SMTP id 5b1f17b1804b1-422b66e9ecemr29240845e9.0.1718285638662; Thu, 13 Jun 2024 06:33:58 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-422870e9145sm62391955e9.22.2024.06.13.06.33.57 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 13 Jun 2024 06:33:58 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 11/30] ada: Streamline elaboration of local tagged types Date: Thu, 13 Jun 2024 15:33:17 +0200 Message-ID: <20240613133338.1809385-11-poulhies@adacore.com> X-Mailer: git-send-email 2.45.1 In-Reply-To: <20240613133338.1809385-1-poulhies@adacore.com> References: <20240613133338.1809385-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, KAM_SHORT, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org From: Eric Botcazou 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 diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 0f5ebb87d73..1512c01f3f8 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -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) \ diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index 12c7d8c226b..70bdd16c3b9 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -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)), diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads index 96cb5663e68..7e987f110b7 100644 --- a/gcc/ada/exp_atag.ads +++ b/gcc/ada/exp_atag.ads @@ -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 diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 1a19c1e3303..666f84ec688 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -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 diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 4f1b310fb84..3cbbf5042f1 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -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 \ diff --git a/gcc/ada/libgnat/a-tags.ads b/gcc/ada/libgnat/a-tags.ads index a36d2df32c1..25a6f7ee599 100644 --- a/gcc/ada/libgnat/a-tags.ads +++ b/gcc/ada/libgnat/a-tags.ads @@ -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 diff --git a/gcc/ada/libgnat/s-addima.adb b/gcc/ada/libgnat/s-addima.adb index 61933edeb97..f1488b6a87d 100644 --- a/gcc/ada/libgnat/s-addima.adb +++ b/gcc/ada/libgnat/s-addima.adb @@ -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; diff --git a/gcc/ada/libgnat/s-imad32.ads b/gcc/ada/libgnat/s-imad32.ads new file mode 100644 index 00000000000..9130c3a4863 --- /dev/null +++ b/gcc/ada/libgnat/s-imad32.ads @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imad64.ads b/gcc/ada/libgnat/s-imad64.ads new file mode 100644 index 00000000000..c8da3ee473f --- /dev/null +++ b/gcc/ada/libgnat/s-imad64.ads @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imagea.adb b/gcc/ada/libgnat/s-imagea.adb new file mode 100644 index 00000000000..abcb883223a --- /dev/null +++ b/gcc/ada/libgnat/s-imagea.adb @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnat/s-imagea.ads b/gcc/ada/libgnat/s-imagea.ads new file mode 100644 index 00000000000..56b42bccae1 --- /dev/null +++ b/gcc/ada/libgnat/s-imagea.ads @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 7c9935e614c..4cfd9fe4a11 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -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 .. diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 50c77867dcd..f4566b4846f 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -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,