https://gcc.gnu.org/g:65dec7e0e4d7987e9fe18065928cf80195784cc0
commit r16-4967-g65dec7e0e4d7987e9fe18065928cf80195784cc0 Author: Ronan Desplanques <[email protected]> Date: Mon Oct 6 17:01:32 2025 +0200 ada: Add System.Traceback.Symbolic.Calling_Entity This patch adds a new convenience function to the runtime library, intended to help with logging. gcc/ada/ChangeLog: * libgnat/s-trasym.ads (Calling_Entity): New function. * libgnat/s-trasym.adb (Calling_Entity): Add dummy body. * libgnat/s-trasym__dwarf.adb (Calling_Entity): New function. (Symbolic_Traceback, Symbolic_Traceback_No_Lock, Module_Symbolic_Traceback, Multi_Module_Symbolic_Traceback): Add Subprg_Name_Only parameter and corresponding functionality. (Symbolic_Traceback_No_Lock): Fix typo in documentation comment. * libgnat/s-dwalin.ads (Symbolic_Traceback): Likewise. * libgnat/s-dwalin.adb (Symbolic_Traceback): Likewise. Diff: --- gcc/ada/libgnat/s-dwalin.adb | 27 +++--- gcc/ada/libgnat/s-dwalin.ads | 11 +-- gcc/ada/libgnat/s-trasym.adb | 4 + gcc/ada/libgnat/s-trasym.ads | 3 + gcc/ada/libgnat/s-trasym__dwarf.adb | 164 +++++++++++++++++++++++------------- 5 files changed, 135 insertions(+), 74 deletions(-) diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb index 1e97a4727dd5..713aad4a304f 100644 --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -1912,11 +1912,12 @@ package body System.Dwarf_Lines is ------------------------ procedure Symbolic_Traceback - (Cin : Dwarf_Context; - Traceback : STE.Tracebacks_Array; - Suppress_Hex : Boolean; - Symbol_Found : out Boolean; - Res : in out System.Bounded_Strings.Bounded_String) + (Cin : Dwarf_Context; + Traceback : STE.Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Symbol_Found : out Boolean; + Res : in out System.Bounded_Strings.Bounded_String) is use Ada.Characters.Handling; C : Dwarf_Context := Cin; @@ -1953,7 +1954,7 @@ package body System.Dwarf_Lines is -- If we're not requested to suppress hex addresses, emit it now. - if not Suppress_Hex then + if not Suppress_Hex and then not Subprg_Name_Only then Append_Address (Res, Addr_In_Traceback); Append (Res, ' '); end if; @@ -2006,10 +2007,12 @@ package body System.Dwarf_Lines is Append (Res, "???"); end if; - Append (Res, " at "); - Append (Res, String (File_Name (1 .. Last))); - Append (Res, ':'); - Append (Res, Line_Image (2 .. Line_Image'Last)); + if not Subprg_Name_Only then + Append (Res, " at "); + Append (Res, String (File_Name (1 .. Last))); + Append (Res, ':'); + Append (Res, Line_Image (2 .. Line_Image'Last)); + end if; end; else if Subprg_Name.Len > 0 then @@ -2020,7 +2023,9 @@ package body System.Dwarf_Lines is Append (Res, "???"); end if; - Append (Res, " at ???"); + if not Subprg_Name_Only then + Append (Res, " at ???"); + end if; end if; Append (Res, ASCII.LF); diff --git a/gcc/ada/libgnat/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads index c65d66effa21..641e515e62f8 100644 --- a/gcc/ada/libgnat/s-dwalin.ads +++ b/gcc/ada/libgnat/s-dwalin.ads @@ -80,11 +80,12 @@ package System.Dwarf_Lines is -- Read symbol information to speed up Symbolic_Traceback. procedure Symbolic_Traceback - (Cin : Dwarf_Context; - Traceback : STE.Tracebacks_Array; - Suppress_Hex : Boolean; - Symbol_Found : out Boolean; - Res : in out System.Bounded_Strings.Bounded_String); + (Cin : Dwarf_Context; + Traceback : STE.Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Symbol_Found : out Boolean; + Res : in out System.Bounded_Strings.Bounded_String); -- Generate a string for a traceback suitable for displaying to the user. -- If one or more symbols are found, Symbol_Found is set to True. This -- allows the caller to fall back to hexadecimal addresses. diff --git a/gcc/ada/libgnat/s-trasym.adb b/gcc/ada/libgnat/s-trasym.adb index 96a19259beaa..5bab088d47a3 100644 --- a/gcc/ada/libgnat/s-trasym.adb +++ b/gcc/ada/libgnat/s-trasym.adb @@ -123,4 +123,8 @@ package body System.Traceback.Symbolic is null; end Enable_Cache; + function Calling_Entity return String is + begin + return "???"; + end Calling_Entity; end System.Traceback.Symbolic; diff --git a/gcc/ada/libgnat/s-trasym.ads b/gcc/ada/libgnat/s-trasym.ads index 96b26cb43543..59939cee70bc 100644 --- a/gcc/ada/libgnat/s-trasym.ads +++ b/gcc/ada/libgnat/s-trasym.ads @@ -105,4 +105,7 @@ package System.Traceback.Symbolic is -- with default value), but backward compatibility for direct calls -- is supported. + function Calling_Entity return String; + -- Return the name of the caller of the current subprogram if it's + -- available. Otherwise return "???". end System.Traceback.Symbolic; diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb index 479b5d34d118..09026c91efe8 100644 --- a/gcc/ada/libgnat/s-trasym__dwarf.adb +++ b/gcc/ada/libgnat/s-trasym__dwarf.adb @@ -96,13 +96,16 @@ package body System.Traceback.Symbolic is -- Initialize Exec_Module if not already initialized function Symbolic_Traceback - (Traceback : System.Traceback_Entries.Tracebacks_Array; - Suppress_Hex : Boolean) return String; + (Traceback : System.Traceback_Entries.Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean) return String; function Symbolic_Traceback (E : Ada.Exceptions.Exception_Occurrence; Suppress_Hex : Boolean) return String; -- Suppress_Hex means do not print any hexadecimal addresses, even if the - -- symbol is not available. + -- symbol is not available. Subprg_Name_Only means to only print the + -- subprogram name for each frame, as opposed to the complete description + -- of the frame. function Lt (Left, Right : Module_Cache_Acc) return Boolean; -- Sort function for Module_Cache @@ -166,30 +169,34 @@ package body System.Traceback.Symbolic is -- Non-symbolic traceback (simply write addresses in hexa) procedure Symbolic_Traceback_No_Lock - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Like the public Symbolic_Traceback_No_Lock except there is no provision - -- against concurrent accesses. + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String); + -- Like the public Symbolic_Traceback except there is no provision against + -- concurrent accesses. procedure Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String); + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String); -- Returns the Traceback for a given module procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String); + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String); -- Build string containing symbolic traceback for the given call chain procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String); + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String); -- Likewise but using Module Max_String_Length : constant := 4096; @@ -328,6 +335,36 @@ package body System.Traceback.Symbolic is Module_Cache_Array_Sort (Modules_Cache.all); end Enable_Cache; + function Calling_Entity return String is + N_Skipped_Frames : constant Natural := 3; + -- We ask Call_Chain to skip the following frames: + -- + -- 1. The frame of Call_Chain itself. + -- 2. The frame of Calling_Entity. + -- 3. The frame of Calling_Entity's caller. + -- + -- The frame above that is the function the caller is looking for. + + Traceback : Tracebacks_Array (1 .. 1); + Len : Natural; + begin + Call_Chain (Traceback, 1, Len, Skip_Frames => N_Skipped_Frames); + + if Len = 0 then + return "???"; + end if; + + declare + With_Trailing_Newline : constant String := + Symbolic_Traceback + (Traceback, Suppress_Hex => True, Subprg_Name_Only => True); + begin + return + With_Trailing_Newline + (With_Trailing_Newline'First .. With_Trailing_Newline'Last - 1); + end; + end Calling_Entity; + --------------------- -- Executable_Name -- --------------------- @@ -450,14 +487,15 @@ package body System.Traceback.Symbolic is ------------------------------- procedure Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String) + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String) is Success : Boolean; begin - if Symbolic.Module_Name.Is_Supported then + if Symbolic.Module_Name.Is_Supported and then not Subprg_Name_Only then Append (Res, '['); Append (Res, Module.Name.all); Append (Res, ']' & ASCII.LF); @@ -467,11 +505,13 @@ package body System.Traceback.Symbolic is (Module.C, Traceback, Suppress_Hex, + Subprg_Name_Only, Success, Res); if not Success then - Hexa_Traceback (Traceback, Suppress_Hex, Res); + Hexa_Traceback + (Traceback, Suppress_Hex or else Subprg_Name_Only, Res); end if; -- We must not allow an unhandled exception here, since this function @@ -487,9 +527,10 @@ package body System.Traceback.Symbolic is ------------------------------------- procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String) + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String) is F : constant Natural := Traceback'First; begin @@ -514,6 +555,7 @@ package body System.Traceback.Symbolic is Multi_Module_Symbolic_Traceback (Traceback, Modules_Cache (Mid).all, + Subprg_Name_Only, Suppress_Hex, Res); return; @@ -527,6 +569,7 @@ package body System.Traceback.Symbolic is Multi_Module_Symbolic_Traceback (Traceback (F + 1 .. Traceback'Last), Suppress_Hex, + Subprg_Name_Only, Res); end; else @@ -534,10 +577,7 @@ package body System.Traceback.Symbolic is -- First try the executable if Is_Inside (Exec_Module.C, Traceback (F)) then Multi_Module_Symbolic_Traceback - (Traceback, - Exec_Module, - Suppress_Hex, - Res); + (Traceback, Exec_Module, Suppress_Hex, Subprg_Name_Only, Res); return; end if; @@ -553,10 +593,7 @@ package body System.Traceback.Symbolic is Init_Module (Module, Success, M_Name, Load_Addr); if Success then Multi_Module_Symbolic_Traceback - (Traceback, - Module, - Suppress_Hex, - Res); + (Traceback, Module, Suppress_Hex, Subprg_Name_Only, Res); Close_Module (Module); else -- Module not found @@ -564,6 +601,7 @@ package body System.Traceback.Symbolic is Multi_Module_Symbolic_Traceback (Traceback (F + 1 .. Traceback'Last), Suppress_Hex, + Subprg_Name_Only, Res); end if; end; @@ -571,10 +609,11 @@ package body System.Traceback.Symbolic is end Multi_Module_Symbolic_Traceback; procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String) + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String) is Pos : Positive; begin @@ -599,10 +638,12 @@ package body System.Traceback.Symbolic is (Traceback (Traceback'First .. Pos - 1), Module, Suppress_Hex, + Subprg_Name_Only, Res); Multi_Module_Symbolic_Traceback (Traceback (Pos .. Traceback'Last), Suppress_Hex, + Subprg_Name_Only, Res); end Multi_Module_Symbolic_Traceback; @@ -633,23 +674,22 @@ package body System.Traceback.Symbolic is -------------------------------- procedure Symbolic_Traceback_No_Lock - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String) is begin if Symbolic.Module_Name.Is_Supported then - Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res); + Multi_Module_Symbolic_Traceback + (Traceback, Suppress_Hex, Subprg_Name_Only, Res); else if Exec_Module_State = Failed then Append (Res, "Call stack traceback locations:" & ASCII.LF); - Hexa_Traceback (Traceback, Suppress_Hex, Res); + Hexa_Traceback + (Traceback, Suppress_Hex or else Subprg_Name_Only, Res); else Module_Symbolic_Traceback - (Traceback, - Exec_Module, - Suppress_Hex, - Res); + (Traceback, Exec_Module, Suppress_Hex, Subprg_Name_Only, Res); end if; end if; end Symbolic_Traceback_No_Lock; @@ -662,8 +702,9 @@ package body System.Traceback.Symbolic is -- Copied from Ada.Exceptions.Exception_Data function Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean) return String + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean) return String is Load_Address : constant Address := Get_Executable_Load_Address; Res : Bounded_String (Max_Length => Max_String_Length); @@ -671,12 +712,13 @@ package body System.Traceback.Symbolic is begin System.Soft_Links.Lock_Task.all; Init_Exec_Module; - if Load_Address /= Null_Address then + if not Subprg_Name_Only and then Load_Address /= Null_Address then Append (Res, LDAD_Header); Append_Address (Res, Load_Address); Append (Res, ASCII.LF); end if; - Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res); + Symbolic_Traceback_No_Lock + (Traceback, Suppress_Hex, Subprg_Name_Only, Res); System.Soft_Links.Unlock_Task.all; return To_String (Res); @@ -690,13 +732,17 @@ package body System.Traceback.Symbolic is function Symbolic_Traceback (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is begin - return Symbolic_Traceback (Traceback, Suppress_Hex => False); + return + Symbolic_Traceback + (Traceback, Suppress_Hex => False, Subprg_Name_Only => False); end Symbolic_Traceback; function Symbolic_Traceback_No_Hex (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is begin - return Symbolic_Traceback (Traceback, Suppress_Hex => True); + return + Symbolic_Traceback + (Traceback, Suppress_Hex => True, Subprg_Name_Only => False); end Symbolic_Traceback_No_Hex; function Symbolic_Traceback @@ -704,9 +750,11 @@ package body System.Traceback.Symbolic is Suppress_Hex : Boolean) return String is begin - return Symbolic_Traceback + return + Symbolic_Traceback (Ada.Exceptions.Traceback.Tracebacks (E), - Suppress_Hex); + Suppress_Hex, + False); end Symbolic_Traceback; function Symbolic_Traceback
