From: Ronan Desplanques <[email protected]>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
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 1e97a4727dd..713aad4a304 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 c65d66effa2..641e515e62f 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 96a19259bea..5bab088d47a 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 96b26cb4354..59939cee70b 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 479b5d34d11..09026c91efe 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
--
2.51.0
