| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1999-2022, AdaCore -- |
| -- -- |
| -- 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. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- Run-time symbolic traceback support for targets using DWARF debug data |
| |
| with Ada.Unchecked_Deallocation; |
| |
| with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; |
| with Ada.Containers.Generic_Array_Sort; |
| |
| with System.Address_To_Access_Conversions; |
| with System.Soft_Links; |
| with System.CRTL; |
| with System.Dwarf_Lines; |
| with System.Exception_Traces; |
| with System.Standard_Library; |
| with System.Traceback_Entries; |
| with System.Strings; |
| with System.Bounded_Strings; |
| |
| package body System.Traceback.Symbolic is |
| |
| use System.Bounded_Strings; |
| use System.Dwarf_Lines; |
| |
| subtype Big_String is String (Positive); |
| -- To deal with C strings |
| |
| package Big_String_Conv is new System.Address_To_Access_Conversions |
| (Big_String); |
| |
| type Module_Cache; |
| type Module_Cache_Acc is access all Module_Cache; |
| |
| type Module_Cache is record |
| Name : Strings.String_Access; |
| -- Name of the module |
| |
| C : Dwarf_Context (In_Exception => True); |
| -- Context to symbolize an address within this module |
| |
| Chain : Module_Cache_Acc; |
| end record; |
| |
| procedure Free is new Ada.Unchecked_Deallocation |
| (Module_Cache, |
| Module_Cache_Acc); |
| |
| Cache_Chain : Module_Cache_Acc; |
| -- Simply linked list of modules |
| |
| type Module_Array is array (Natural range <>) of Module_Cache_Acc; |
| type Module_Array_Acc is access Module_Array; |
| |
| Modules_Cache : Module_Array_Acc; |
| -- Sorted array of cached modules (if not null) |
| |
| Exec_Module : aliased Module_Cache; |
| -- Context for the executable |
| |
| type Init_State is (Uninitialized, Initialized, Failed); |
| Exec_Module_State : Init_State := Uninitialized; |
| -- How Exec_Module is initialized |
| |
| procedure Init_Exec_Module; |
| -- Initialize Exec_Module if not already initialized |
| |
| function Symbolic_Traceback |
| (Traceback : System.Traceback_Entries.Tracebacks_Array; |
| Suppress_Hex : 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. |
| |
| function Lt (Left, Right : Module_Cache_Acc) return Boolean; |
| -- Sort function for Module_Cache |
| |
| procedure Init_Module |
| (Module : out Module_Cache; |
| Success : out Boolean; |
| Module_Name : String; |
| Load_Address : Address := Null_Address); |
| -- Initialize Module |
| |
| procedure Close_Module (Module : in out Module_Cache); |
| -- Finalize Module |
| |
| function Value (Item : System.Address) return String; |
| -- Return the String contained in Item, up until the first NUL character |
| |
| pragma Warnings (Off, "*Add_Module_To_Cache*"); |
| procedure Add_Module_To_Cache (Module_Name : String; |
| Load_Address : System.Address); |
| -- To be called by Build_Cache_For_All_Modules to add a new module to the |
| -- list. May not be referenced. |
| |
| package Module_Name is |
| |
| procedure Build_Cache_For_All_Modules; |
| -- Create the cache for all current modules |
| |
| function Get (Addr : System.Address; |
| Load_Addr : access System.Address) return String; |
| -- Returns the module name for the given address Addr, or an empty |
| -- string for the main executable. Load_Addr is set to the shared |
| -- library load address if this information is available, or to |
| -- System.Null_Address otherwise. |
| |
| function Is_Supported return Boolean; |
| pragma Inline (Is_Supported); |
| -- Returns True if Module_Name is supported, so if the traceback is |
| -- supported for shared libraries. |
| |
| end Module_Name; |
| |
| package body Module_Name is separate; |
| |
| function Executable_Name return String; |
| -- Returns the executable name as reported by argv[0]. If gnat_argv not |
| -- initialized, return an empty string. If the argv[0] executable is not |
| -- found in the PATH, return it unresolved. |
| |
| function Get_Executable_Load_Address return System.Address; |
| pragma Import |
| (C, |
| Get_Executable_Load_Address, |
| "__gnat_get_executable_load_address"); |
| -- Get the load address of the executable, or Null_Address if not known |
| |
| procedure Hexa_Traceback |
| (Traceback : Tracebacks_Array; |
| Suppress_Hex : Boolean; |
| Res : in out Bounded_String); |
| -- 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. |
| |
| procedure Module_Symbolic_Traceback |
| (Traceback : Tracebacks_Array; |
| Module : Module_Cache; |
| Suppress_Hex : 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); |
| -- 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); |
| -- Likewise but using Module |
| |
| Max_String_Length : constant := 4096; |
| -- Arbitrary limit on Bounded_Str length |
| |
| ----------- |
| -- Value -- |
| ----------- |
| |
| function Value (Item : System.Address) return String is |
| begin |
| if Item /= Null_Address then |
| for J in Big_String'Range loop |
| if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then |
| return Big_String_Conv.To_Pointer (Item) (1 .. J - 1); |
| end if; |
| end loop; |
| end if; |
| |
| return ""; |
| end Value; |
| |
| ------------------------- |
| -- Add_Module_To_Cache -- |
| ------------------------- |
| |
| procedure Add_Module_To_Cache (Module_Name : String; |
| Load_Address : System.Address) |
| is |
| Module : Module_Cache_Acc; |
| Success : Boolean; |
| begin |
| Module := new Module_Cache; |
| Init_Module (Module.all, Success, Module_Name, Load_Address); |
| if not Success then |
| Free (Module); |
| return; |
| end if; |
| Module.Chain := Cache_Chain; |
| Cache_Chain := Module; |
| end Add_Module_To_Cache; |
| |
| ---------------------- |
| -- Init_Exec_Module -- |
| ---------------------- |
| |
| procedure Init_Exec_Module is |
| begin |
| if Exec_Module_State = Uninitialized then |
| declare |
| Exec_Path : constant String := Executable_Name; |
| Exec_Load : constant Address := Get_Executable_Load_Address; |
| Success : Boolean; |
| begin |
| Init_Module (Exec_Module, Success, Exec_Path, Exec_Load); |
| |
| if Success then |
| Exec_Module_State := Initialized; |
| else |
| Exec_Module_State := Failed; |
| end if; |
| end; |
| end if; |
| end Init_Exec_Module; |
| |
| -------- |
| -- Lt -- |
| -------- |
| |
| function Lt (Left, Right : Module_Cache_Acc) return Boolean is |
| begin |
| return Low_Address (Left.C) < Low_Address (Right.C); |
| end Lt; |
| |
| ----------------------------- |
| -- Module_Cache_Array_Sort -- |
| ----------------------------- |
| |
| procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort |
| (Natural, |
| Module_Cache_Acc, |
| Module_Array, |
| Lt); |
| |
| ------------------ |
| -- Enable_Cache -- |
| ------------------ |
| |
| procedure Enable_Cache (Include_Modules : Boolean := False) is |
| begin |
| -- Can be called at most once |
| if Cache_Chain /= null then |
| return; |
| end if; |
| |
| -- Add all modules |
| Init_Exec_Module; |
| |
| if Exec_Module_State = Failed then |
| raise Program_Error with |
| "cannot enable cache, executable state initialization failed."; |
| end if; |
| |
| Cache_Chain := Exec_Module'Access; |
| |
| if Include_Modules then |
| Module_Name.Build_Cache_For_All_Modules; |
| end if; |
| |
| -- Build and fill the array of modules |
| declare |
| Count : Natural; |
| Module : Module_Cache_Acc; |
| begin |
| for Phase in 1 .. 2 loop |
| Count := 0; |
| Module := Cache_Chain; |
| while Module /= null loop |
| Count := Count + 1; |
| |
| if Phase = 1 then |
| Enable_Cache (Module.C); |
| else |
| Modules_Cache (Count) := Module; |
| end if; |
| Module := Module.Chain; |
| end loop; |
| |
| if Phase = 1 then |
| Modules_Cache := new Module_Array (1 .. Count); |
| end if; |
| end loop; |
| end; |
| |
| -- Sort the array |
| Module_Cache_Array_Sort (Modules_Cache.all); |
| end Enable_Cache; |
| |
| --------------------- |
| -- Executable_Name -- |
| --------------------- |
| |
| function Executable_Name return String is |
| -- We have to import gnat_argv as an Address to match the type of |
| -- gnat_argv in the binder generated file. Otherwise, we get spurious |
| -- warnings about type mismatch when LTO is turned on. |
| |
| Gnat_Argv : System.Address; |
| pragma Import (C, Gnat_Argv, "gnat_argv"); |
| |
| type Argv_Array is array (0 .. 0) of System.Address; |
| package Conv is new System.Address_To_Access_Conversions (Argv_Array); |
| |
| function locate_exec_on_path (A : System.Address) return System.Address; |
| pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path"); |
| |
| begin |
| if Gnat_Argv = Null_Address then |
| return ""; |
| end if; |
| |
| -- See if we can resolve argv[0] to a full path (to a file that we will |
| -- be able to open). If the resolution fails, we were probably spawned |
| -- by an imprecise exec call, typically passing a mere file name as |
| -- argv[0] for a program in the current directory with '.' not on PATH. |
| -- Best we can do is fallback to argv[0] unchanged in this case. If we |
| -- fail opening that downstream, we'll just bail out. |
| |
| declare |
| Argv0 : constant System.Address |
| := Conv.To_Pointer (Gnat_Argv) (0); |
| |
| Resolved_Argv0 : constant System.Address |
| := locate_exec_on_path (Argv0); |
| |
| Exe_Argv : constant System.Address |
| := (if Resolved_Argv0 /= System.Null_Address |
| then Resolved_Argv0 |
| else Argv0); |
| |
| Result : constant String := Value (Exe_Argv); |
| |
| begin |
| -- The buffer returned by locate_exec_on_path was allocated using |
| -- malloc and we should release this memory. |
| |
| if Resolved_Argv0 /= Null_Address then |
| System.CRTL.free (Resolved_Argv0); |
| end if; |
| |
| return Result; |
| end; |
| end Executable_Name; |
| |
| ------------------ |
| -- Close_Module -- |
| ------------------ |
| |
| procedure Close_Module (Module : in out Module_Cache) is |
| begin |
| Close (Module.C); |
| Strings.Free (Module.Name); |
| end Close_Module; |
| |
| ----------------- |
| -- Init_Module -- |
| ----------------- |
| |
| procedure Init_Module |
| (Module : out Module_Cache; |
| Success : out Boolean; |
| Module_Name : String; |
| Load_Address : Address := Null_Address) |
| is |
| begin |
| -- Early return if the module is not known |
| |
| if Module_Name = "" then |
| Success := False; |
| return; |
| end if; |
| |
| Open (Module_Name, Module.C, Success); |
| |
| -- If a module can't be opened just return now, we just cannot give more |
| -- information in this case. |
| |
| if not Success then |
| return; |
| end if; |
| |
| Set_Load_Address (Module.C, Load_Address); |
| |
| Module.Name := new String'(Module_Name); |
| end Init_Module; |
| |
| ------------------------------- |
| -- Module_Symbolic_Traceback -- |
| ------------------------------- |
| |
| procedure Module_Symbolic_Traceback |
| (Traceback : Tracebacks_Array; |
| Module : Module_Cache; |
| Suppress_Hex : Boolean; |
| Res : in out Bounded_String) |
| is |
| Success : Boolean; |
| begin |
| if Symbolic.Module_Name.Is_Supported then |
| Append (Res, '['); |
| Append (Res, Module.Name.all); |
| Append (Res, ']' & ASCII.LF); |
| end if; |
| |
| Dwarf_Lines.Symbolic_Traceback |
| (Module.C, |
| Traceback, |
| Suppress_Hex, |
| Success, |
| Res); |
| |
| if not Success then |
| Hexa_Traceback (Traceback, Suppress_Hex, Res); |
| end if; |
| |
| -- We must not allow an unhandled exception here, since this function |
| -- may be installed as a decorator for all automatic exceptions. |
| |
| exception |
| when others => |
| return; |
| end Module_Symbolic_Traceback; |
| |
| ------------------------------------- |
| -- Multi_Module_Symbolic_Traceback -- |
| ------------------------------------- |
| |
| procedure Multi_Module_Symbolic_Traceback |
| (Traceback : Tracebacks_Array; |
| Suppress_Hex : Boolean; |
| Res : in out Bounded_String) |
| is |
| F : constant Natural := Traceback'First; |
| begin |
| if Traceback'Length = 0 or else Is_Full (Res) then |
| return; |
| end if; |
| |
| if Modules_Cache /= null then |
| -- Search in the cache |
| |
| declare |
| Addr : constant Address := Traceback (F); |
| Hi, Lo, Mid : Natural; |
| begin |
| Lo := Modules_Cache'First; |
| Hi := Modules_Cache'Last; |
| while Lo <= Hi loop |
| Mid := (Lo + Hi) / 2; |
| if Addr < Low_Address (Modules_Cache (Mid).C) then |
| Hi := Mid - 1; |
| elsif Is_Inside (Modules_Cache (Mid).C, Addr) then |
| Multi_Module_Symbolic_Traceback |
| (Traceback, |
| Modules_Cache (Mid).all, |
| Suppress_Hex, |
| Res); |
| return; |
| else |
| Lo := Mid + 1; |
| end if; |
| end loop; |
| |
| -- Not found |
| Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res); |
| Multi_Module_Symbolic_Traceback |
| (Traceback (F + 1 .. Traceback'Last), |
| Suppress_Hex, |
| Res); |
| end; |
| else |
| |
| -- First try the executable |
| if Is_Inside (Exec_Module.C, Traceback (F)) then |
| Multi_Module_Symbolic_Traceback |
| (Traceback, |
| Exec_Module, |
| Suppress_Hex, |
| Res); |
| return; |
| end if; |
| |
| -- Otherwise, try a shared library |
| declare |
| Load_Addr : aliased System.Address; |
| M_Name : constant String := |
| Module_Name.Get (Addr => Traceback (F), |
| Load_Addr => Load_Addr'Access); |
| Module : Module_Cache; |
| Success : Boolean; |
| begin |
| Init_Module (Module, Success, M_Name, Load_Addr); |
| if Success then |
| Multi_Module_Symbolic_Traceback |
| (Traceback, |
| Module, |
| Suppress_Hex, |
| Res); |
| Close_Module (Module); |
| else |
| -- Module not found |
| Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res); |
| Multi_Module_Symbolic_Traceback |
| (Traceback (F + 1 .. Traceback'Last), |
| Suppress_Hex, |
| Res); |
| end if; |
| end; |
| end if; |
| end Multi_Module_Symbolic_Traceback; |
| |
| procedure Multi_Module_Symbolic_Traceback |
| (Traceback : Tracebacks_Array; |
| Module : Module_Cache; |
| Suppress_Hex : Boolean; |
| Res : in out Bounded_String) |
| is |
| Pos : Positive; |
| begin |
| -- Will symbolize the first address... |
| |
| Pos := Traceback'First + 1; |
| |
| -- ... and all addresses in the same module |
| |
| Same_Module : |
| loop |
| exit Same_Module when Pos > Traceback'Last; |
| |
| -- Get address to check for corresponding module name |
| |
| exit Same_Module when not Is_Inside (Module.C, Traceback (Pos)); |
| |
| Pos := Pos + 1; |
| end loop Same_Module; |
| |
| Module_Symbolic_Traceback |
| (Traceback (Traceback'First .. Pos - 1), |
| Module, |
| Suppress_Hex, |
| Res); |
| Multi_Module_Symbolic_Traceback |
| (Traceback (Pos .. Traceback'Last), |
| Suppress_Hex, |
| Res); |
| end Multi_Module_Symbolic_Traceback; |
| |
| -------------------- |
| -- Hexa_Traceback -- |
| -------------------- |
| |
| procedure Hexa_Traceback |
| (Traceback : Tracebacks_Array; |
| Suppress_Hex : Boolean; |
| Res : in out Bounded_String) |
| is |
| use System.Traceback_Entries; |
| begin |
| if Suppress_Hex then |
| Append (Res, "..."); |
| Append (Res, ASCII.LF); |
| else |
| for J in Traceback'Range loop |
| Append_Address (Res, PC_For (Traceback (J))); |
| Append (Res, ASCII.LF); |
| end loop; |
| end if; |
| end Hexa_Traceback; |
| |
| -------------------------------- |
| -- Symbolic_Traceback_No_Lock -- |
| -------------------------------- |
| |
| procedure Symbolic_Traceback_No_Lock |
| (Traceback : Tracebacks_Array; |
| Suppress_Hex : Boolean; |
| Res : in out Bounded_String) |
| is |
| begin |
| if Symbolic.Module_Name.Is_Supported then |
| Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res); |
| else |
| if Exec_Module_State = Failed then |
| Append (Res, "Call stack traceback locations:" & ASCII.LF); |
| Hexa_Traceback (Traceback, Suppress_Hex, Res); |
| else |
| Module_Symbolic_Traceback |
| (Traceback, |
| Exec_Module, |
| Suppress_Hex, |
| Res); |
| end if; |
| end if; |
| end Symbolic_Traceback_No_Lock; |
| |
| ------------------------ |
| -- Symbolic_Traceback -- |
| ------------------------ |
| |
| function Symbolic_Traceback |
| (Traceback : Tracebacks_Array; |
| Suppress_Hex : Boolean) return String |
| is |
| Res : Bounded_String (Max_Length => Max_String_Length); |
| begin |
| System.Soft_Links.Lock_Task.all; |
| Init_Exec_Module; |
| Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res); |
| System.Soft_Links.Unlock_Task.all; |
| |
| return To_String (Res); |
| |
| exception |
| when others => |
| System.Soft_Links.Unlock_Task.all; |
| raise; |
| end Symbolic_Traceback; |
| |
| function Symbolic_Traceback |
| (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is |
| begin |
| return Symbolic_Traceback (Traceback, Suppress_Hex => 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); |
| end Symbolic_Traceback_No_Hex; |
| |
| function Symbolic_Traceback |
| (E : Ada.Exceptions.Exception_Occurrence; |
| Suppress_Hex : Boolean) return String |
| is |
| begin |
| return Symbolic_Traceback |
| (Ada.Exceptions.Traceback.Tracebacks (E), |
| Suppress_Hex); |
| end Symbolic_Traceback; |
| |
| function Symbolic_Traceback |
| (E : Ada.Exceptions.Exception_Occurrence) return String |
| is |
| begin |
| return Symbolic_Traceback (E, Suppress_Hex => False); |
| end Symbolic_Traceback; |
| |
| function Symbolic_Traceback_No_Hex |
| (E : Ada.Exceptions.Exception_Occurrence) return String is |
| begin |
| return Symbolic_Traceback (E, Suppress_Hex => True); |
| end Symbolic_Traceback_No_Hex; |
| |
| Exception_Tracebacks_Symbolic : constant Integer; |
| pragma Import |
| (C, |
| Exception_Tracebacks_Symbolic, |
| "__gl_exception_tracebacks_symbolic"); |
| -- Boolean indicating whether symbolic tracebacks should be generated. |
| |
| use Standard_Library; |
| begin |
| -- If this version of this package is available, and the binder switch -Es |
| -- was given, then we want to use this as the decorator by default, and we |
| -- want to turn on tracing for Unhandled_Raise_In_Main. Note that the user |
| -- cannot have already set Exception_Trace, because the runtime library is |
| -- elaborated before user-defined code. |
| |
| if Exception_Tracebacks_Symbolic /= 0 then |
| Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access); |
| pragma Assert (Exception_Trace = RM_Convention); |
| Exception_Trace := Unhandled_Raise_In_Main; |
| end if; |
| end System.Traceback.Symbolic; |
