s-dwalin.ads, [...]: New.
2017-09-08 Arnaud Charlet <charlet@adacore.com> * s-dwalin.ads, s-dwalin.adb, s-trasym-dwarf.adb, s-objrea.ads, s-objrea.adb, s-tsmona-linux.adb, s-tsmona-mingw.adb: New. * gcc-interface/Makefile.in: Enable s-trasym-dwarf.adb on x86*linux. From-SVN: r251887
This commit is contained in:
Arnaud Charlet
parent
6a237c4530
commit
a2529c0aa7
|
|
@ -429,6 +429,25 @@ X86_64_TARGET_PAIRS = \
|
|||
a-numaux.adb<a-numaux-x86.adb \
|
||||
s-atocou.adb<s-atocou-builtin.adb
|
||||
|
||||
# Implementation of symbolic traceback based on dwarf
|
||||
TRASYM_DWARF_UNIX_PAIRS = \
|
||||
s-trasym.adb<s-trasym-dwarf.adb \
|
||||
s-mmosin.ads<s-mmosin-unix.ads \
|
||||
s-mmosin.adb<s-mmosin-unix.adb \
|
||||
s-mmauni.ads<s-mmauni-long.ads
|
||||
|
||||
TRASYM_DWARF_MINGW_PAIRS = \
|
||||
s-trasym.adb<s-trasym-dwarf.adb \
|
||||
s-mmosin.ads<s-mmosin-mingw.ads \
|
||||
s-mmosin.adb<s-mmosin-mingw.adb
|
||||
|
||||
TRASYM_DWARF_COMMON_OBJS = s-objrea$(objext) s-dwalin$(objext) s-mmap$(objext) \
|
||||
s-mmosin$(objext)
|
||||
|
||||
TRASYM_DWARF_UNIX_OBJS = $(TRASYM_DWARF_COMMON_OBJS) s-mmauni$(objext)
|
||||
|
||||
TRASYM_DWARF_MINGW_OBJS = $(TRASYM_DWARF_COMMON_OBJS)
|
||||
|
||||
# Shared library version
|
||||
LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)ada/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/'))
|
||||
|
||||
|
|
@ -1085,7 +1104,9 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),)
|
|||
s-inmaop.adb<s-inmaop-posix.adb \
|
||||
s-intman.adb<s-intman-posix.adb \
|
||||
s-tpopsp.adb<s-tpopsp-tls.adb \
|
||||
$(TRASYM_DWARF_UNIX_PAIRS) \
|
||||
g-sercom.adb<g-sercom-linux.adb \
|
||||
s-tsmona.adb<s-tsmona-linux.adb \
|
||||
a-exetim.adb<a-exetim-posix.adb \
|
||||
a-exetim.ads<a-exetim-default.ads \
|
||||
s-linux.ads<s-linux.ads \
|
||||
|
|
@ -1111,6 +1132,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),)
|
|||
EH_MECHANISM=-gcc
|
||||
THREADSLIB = -lpthread -lrt
|
||||
EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
|
||||
EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS)
|
||||
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
|
||||
|
||||
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
|
||||
|
|
@ -1907,6 +1929,8 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),)
|
|||
s-tpopsp.adb<s-tpopsp-tls.adb \
|
||||
s-taspri.ads<s-taspri-posix.ads \
|
||||
g-sercom.adb<g-sercom-linux.adb \
|
||||
$(TRASYM_DWARF_UNIX_PAIRS) \
|
||||
s-tsmona.adb<s-tsmona-linux.adb \
|
||||
$(ATOMICS_TARGET_PAIRS) \
|
||||
$(X86_64_TARGET_PAIRS) \
|
||||
system.ads<system-linux-x86.ads
|
||||
|
|
@ -1914,6 +1938,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),)
|
|||
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
|
||||
|
||||
EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
|
||||
EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS)
|
||||
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
|
||||
|
||||
EH_MECHANISM=-gcc
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,191 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M . D W A R F _ L I N E S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2009-2017, 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. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package provides routines to read DWARF line number information from
|
||||
-- a generic object file with as little overhead as possible. This allows
|
||||
-- conversions from PC addresses to human readable source locations.
|
||||
--
|
||||
-- Objects must be built with debugging information, however only the
|
||||
-- .debug_line section of the object file is referenced. In cases where object
|
||||
-- size is a consideration it's possible to strip all other .debug sections,
|
||||
-- which will decrease the size of the object significantly.
|
||||
|
||||
pragma Polling (Off);
|
||||
-- We must turn polling off for this unit, because otherwise we can get
|
||||
-- elaboration circularities when polling is turned on
|
||||
|
||||
with Ada.Exceptions.Traceback;
|
||||
|
||||
with System.Object_Reader;
|
||||
with System.Storage_Elements;
|
||||
with System.Bounded_Strings;
|
||||
|
||||
package System.Dwarf_Lines is
|
||||
|
||||
package AET renames Ada.Exceptions.Traceback;
|
||||
package SOR renames System.Object_Reader;
|
||||
|
||||
type Dwarf_Context (In_Exception : Boolean := False) is private;
|
||||
-- Type encapsulation the state of the Dwarf reader. When In_Exception
|
||||
-- is True we are parsing as part of a exception handler decorator, we do
|
||||
-- not want an exception to be raised, the parsing is done safely skipping
|
||||
-- DWARF file that cannot be read or with stripped debug section for
|
||||
-- example.
|
||||
|
||||
procedure Open
|
||||
(File_Name : String;
|
||||
C : out Dwarf_Context;
|
||||
Success : out Boolean);
|
||||
procedure Close (C : in out Dwarf_Context);
|
||||
-- Open and close files
|
||||
|
||||
procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address);
|
||||
-- Set the load address of a file. This is used to rebase PIE (Position
|
||||
-- Independant Executable) binaries.
|
||||
|
||||
function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean;
|
||||
pragma Inline (Is_Inside);
|
||||
-- Return true iff Addr is within the module
|
||||
|
||||
function Low (C : Dwarf_Context) return Address;
|
||||
pragma Inline (Low);
|
||||
-- Return the lowest address of C
|
||||
|
||||
procedure Dump (C : in out Dwarf_Context);
|
||||
-- Dump each row found in the object's .debug_lines section to standard out
|
||||
|
||||
procedure Dump_Cache (C : Dwarf_Context);
|
||||
-- Dump the cache (if present)
|
||||
|
||||
procedure Enable_Cache (C : in out Dwarf_Context);
|
||||
-- Read symbols information to speed up Symbolic_Traceback.
|
||||
|
||||
procedure Symbolic_Traceback
|
||||
(Cin : Dwarf_Context;
|
||||
Traceback : AET.Tracebacks_Array;
|
||||
Suppress_Hex : Boolean;
|
||||
Symbol_Found : in 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.
|
||||
|
||||
Dwarf_Error : exception;
|
||||
-- Raised if a problem is encountered parsing DWARF information. Can be a
|
||||
-- result of a logic error or malformed DWARF information.
|
||||
|
||||
private
|
||||
-- The following section numbers reference
|
||||
|
||||
-- "DWARF Debugging Information Format, Version 3"
|
||||
|
||||
-- published by the Standards Group, http://freestandards.org.
|
||||
|
||||
-- 6.2.2 State Machine Registers
|
||||
|
||||
type Line_Info_Registers is record
|
||||
Address : SOR.uint64;
|
||||
File : SOR.uint32;
|
||||
Line : SOR.uint32;
|
||||
Column : SOR.uint32;
|
||||
Is_Stmt : Boolean;
|
||||
Basic_Block : Boolean;
|
||||
End_Sequence : Boolean;
|
||||
Prologue_End : Boolean;
|
||||
Epilogue_Begin : Boolean;
|
||||
ISA : SOR.uint32;
|
||||
Is_Row : Boolean;
|
||||
end record;
|
||||
|
||||
-- 6.2.4 The Line Number Program Prologue
|
||||
|
||||
MAX_OPCODE_LENGTHS : constant := 256;
|
||||
|
||||
type Opcodes_Lengths_Array is
|
||||
array (SOR.uint32 range 1 .. MAX_OPCODE_LENGTHS) of SOR.uint8;
|
||||
|
||||
type Line_Info_Prologue is record
|
||||
Unit_Length : SOR.uint32;
|
||||
Version : SOR.uint16;
|
||||
Prologue_Length : SOR.uint32;
|
||||
Min_Isn_Length : SOR.uint8;
|
||||
Default_Is_Stmt : SOR.uint8;
|
||||
Line_Base : SOR.int8;
|
||||
Line_Range : SOR.uint8;
|
||||
Opcode_Base : SOR.uint8;
|
||||
Opcode_Lengths : Opcodes_Lengths_Array;
|
||||
Includes_Offset : SOR.Offset;
|
||||
File_Names_Offset : SOR.Offset;
|
||||
end record;
|
||||
|
||||
type Search_Entry is record
|
||||
First : SOR.uint32;
|
||||
Size : SOR.uint32;
|
||||
-- Function bounds as offset to the base address.
|
||||
|
||||
Sym : SOR.uint32;
|
||||
-- Symbol offset to get the name.
|
||||
|
||||
Line : SOR.uint32;
|
||||
-- Dwarf line offset.
|
||||
end record;
|
||||
|
||||
type Search_Array is array (Natural range <>) of Search_Entry;
|
||||
|
||||
type Search_Array_Access is access Search_Array;
|
||||
|
||||
type Dwarf_Context (In_Exception : Boolean := False) is record
|
||||
Load_Slide : System.Storage_Elements.Integer_Address := 0;
|
||||
Low, High : Address;
|
||||
-- Bounds of the module
|
||||
|
||||
Obj : SOR.Object_File_Access;
|
||||
-- The object file containing dwarf sections
|
||||
|
||||
Has_Debug : Boolean;
|
||||
-- True if all debug sections are available
|
||||
|
||||
Cache : Search_Array_Access;
|
||||
-- Quick access to symbol and debug info (when present).
|
||||
|
||||
Lines : SOR.Mapped_Stream;
|
||||
Aranges : SOR.Mapped_Stream;
|
||||
Info : SOR.Mapped_Stream;
|
||||
Abbrev : SOR.Mapped_Stream;
|
||||
-- Dwarf line, aranges, info and abbrev sections
|
||||
|
||||
Prologue : Line_Info_Prologue;
|
||||
Registers : Line_Info_Registers;
|
||||
Next_Prologue : SOR.Offset;
|
||||
-- State for lines
|
||||
end record;
|
||||
|
||||
end System.Dwarf_Lines;
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,451 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M . O B J E C T _ R E A D E R --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2009-2017, 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. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package implements a simple, minimal overhead reader for object files
|
||||
-- composed of sections of untyped heterogeneous binary data.
|
||||
|
||||
with Interfaces;
|
||||
with System.Mmap;
|
||||
|
||||
package System.Object_Reader is
|
||||
|
||||
--------------
|
||||
-- Limits --
|
||||
--------------
|
||||
|
||||
BUFFER_SIZE : constant := 8 * 1024;
|
||||
|
||||
------------------
|
||||
-- Object files --
|
||||
------------------
|
||||
|
||||
type Object_File (<>) is private;
|
||||
|
||||
type Object_File_Access is access Object_File;
|
||||
|
||||
---------------------
|
||||
-- Object sections --
|
||||
----------------------
|
||||
|
||||
type Object_Section is private;
|
||||
|
||||
Null_Section : constant Object_Section;
|
||||
|
||||
--------------------
|
||||
-- Object symbols --
|
||||
--------------------
|
||||
|
||||
type Object_Symbol is private;
|
||||
|
||||
------------------------
|
||||
-- Object format type --
|
||||
------------------------
|
||||
|
||||
type Object_Format is
|
||||
(ELF32,
|
||||
-- Object format is 32-bit ELF
|
||||
|
||||
ELF64,
|
||||
-- Object format is 64-bit ELF
|
||||
|
||||
PECOFF,
|
||||
-- Object format is Microsoft PECOFF
|
||||
|
||||
PECOFF_PLUS,
|
||||
-- Object format is Microsoft PECOFF+
|
||||
|
||||
XCOFF32);
|
||||
-- Object format is AIX 32-bit XCOFF
|
||||
|
||||
-- PECOFF | PECOFF_PLUS appears so often as a case choice, would
|
||||
-- seem a good idea to have a subtype name covering these two choices ???
|
||||
|
||||
------------------------------
|
||||
-- Object architecture type --
|
||||
------------------------------
|
||||
|
||||
type Object_Arch is
|
||||
(Unknown,
|
||||
-- The target architecture has not yet been determined
|
||||
|
||||
SPARC,
|
||||
-- 32-bit SPARC
|
||||
|
||||
SPARC64,
|
||||
-- 64-bit SPARC
|
||||
|
||||
i386,
|
||||
-- Intel IA32
|
||||
|
||||
MIPS,
|
||||
-- MIPS Technologies MIPS
|
||||
|
||||
x86_64,
|
||||
-- x86-64 (64-bit AMD/Intel)
|
||||
|
||||
IA64,
|
||||
-- Intel IA64
|
||||
|
||||
PPC,
|
||||
-- 32-bit PowerPC
|
||||
|
||||
PPC64);
|
||||
-- 64-bit PowerPC
|
||||
|
||||
------------------
|
||||
-- Target types --
|
||||
------------------
|
||||
|
||||
subtype Offset is Interfaces.Integer_64;
|
||||
|
||||
subtype uint8 is Interfaces.Unsigned_8;
|
||||
subtype uint16 is Interfaces.Unsigned_16;
|
||||
subtype uint32 is Interfaces.Unsigned_32;
|
||||
subtype uint64 is Interfaces.Unsigned_64;
|
||||
|
||||
subtype int8 is Interfaces.Integer_8;
|
||||
subtype int16 is Interfaces.Integer_16;
|
||||
subtype int32 is Interfaces.Integer_32;
|
||||
subtype int64 is Interfaces.Integer_64;
|
||||
|
||||
type Buffer is array (0 .. BUFFER_SIZE - 1) of uint8;
|
||||
|
||||
type String_Ptr_Len is record
|
||||
Ptr : Mmap.Str_Access;
|
||||
Len : Natural;
|
||||
end record;
|
||||
-- A string made from a pointer and a length. Not all strings for name
|
||||
-- are C strings: COFF inlined symbol names have a max length of 8.
|
||||
|
||||
-------------------------------------------
|
||||
-- Operations on buffers of untyped data --
|
||||
-------------------------------------------
|
||||
|
||||
function To_String (Buf : Buffer) return String;
|
||||
-- Construct string from C style null-terminated string stored in a buffer
|
||||
|
||||
function To_String_Ptr_Len
|
||||
(Ptr : Mmap.Str_Access;
|
||||
Max_Len : Natural := Natural'Last) return String_Ptr_Len;
|
||||
-- Convert PTR to a String_Ptr_Len.
|
||||
|
||||
function Strlen (Buf : Buffer) return int32;
|
||||
-- Return the length of a C style null-terminated string
|
||||
|
||||
-------------------------
|
||||
-- Opening and closing --
|
||||
-------------------------
|
||||
|
||||
function Open
|
||||
(File_Name : String;
|
||||
In_Exception : Boolean := False) return Object_File_Access;
|
||||
-- Open the object file and initialize the reader. In_Exception is true
|
||||
-- when the parsing is done as part of an exception handler decorator. In
|
||||
-- this mode we do not want to raise an exception.
|
||||
|
||||
procedure Close (Obj : in out Object_File);
|
||||
-- Close the object file
|
||||
|
||||
-----------------------
|
||||
-- Sequential access --
|
||||
-----------------------
|
||||
|
||||
type Mapped_Stream is private;
|
||||
-- Provide an abstraction of a stream on a memory mapped file
|
||||
|
||||
function Create_Stream (Mf : System.Mmap.Mapped_File;
|
||||
File_Offset : System.Mmap.File_Size;
|
||||
File_Length : System.Mmap.File_Size)
|
||||
return Mapped_Stream;
|
||||
-- Create a stream from Mf
|
||||
|
||||
procedure Close (S : in out Mapped_Stream);
|
||||
-- Close the stream (deallocate memory)
|
||||
|
||||
procedure Read_Raw
|
||||
(S : in out Mapped_Stream;
|
||||
Addr : Address;
|
||||
Size : uint32);
|
||||
pragma Inline (Read_Raw);
|
||||
-- Read a number of fixed sized records
|
||||
|
||||
procedure Seek (S : in out Mapped_Stream; Off : Offset);
|
||||
-- Seek to an absolute offset in bytes
|
||||
|
||||
procedure Tell (Obj : in out Mapped_Stream; Off : out Offset)
|
||||
with Inline;
|
||||
function Tell (Obj : Mapped_Stream) return Offset
|
||||
with Inline;
|
||||
-- Fetch the current offset
|
||||
|
||||
function Length (Obj : Mapped_Stream) return Offset
|
||||
with Inline;
|
||||
-- Length of the stream
|
||||
|
||||
function Read (S : in out Mapped_Stream) return Mmap.Str_Access;
|
||||
-- Provide a pointer in memory at the current offset
|
||||
|
||||
function Read (S : in out Mapped_Stream) return String_Ptr_Len;
|
||||
-- Provide a pointer in memory at the current offset
|
||||
|
||||
function Read (S : in out Mapped_Stream) return uint8;
|
||||
function Read (S : in out Mapped_Stream) return uint16;
|
||||
function Read (S : in out Mapped_Stream) return uint32;
|
||||
function Read (S : in out Mapped_Stream) return uint64;
|
||||
function Read (S : in out Mapped_Stream) return int8;
|
||||
function Read (S : in out Mapped_Stream) return int16;
|
||||
function Read (S : in out Mapped_Stream) return int32;
|
||||
function Read (S : in out Mapped_Stream) return int64;
|
||||
-- Read a scalar
|
||||
|
||||
function Read_Address
|
||||
(Obj : Object_File; S : in out Mapped_Stream) return uint64;
|
||||
-- Read either a 64 or 32 bit address from the file stream depending on the
|
||||
-- address size of the target architecture and promote it to a 64 bit type.
|
||||
|
||||
function Read_LEB128 (S : in out Mapped_Stream) return uint32;
|
||||
function Read_LEB128 (S : in out Mapped_Stream) return int32;
|
||||
-- Read a value encoding in Little-Endian Base 128 format
|
||||
|
||||
procedure Read_C_String (S : in out Mapped_Stream; B : out Buffer);
|
||||
function Read_C_String (S : in out Mapped_Stream) return Mmap.Str_Access;
|
||||
-- Read a C style NULL terminated string
|
||||
|
||||
function Offset_To_String
|
||||
(S : in out Mapped_Stream;
|
||||
Off : Offset) return String;
|
||||
-- Construct a string from a C style NULL terminated string located at an
|
||||
-- offset into the object file.
|
||||
|
||||
------------------------
|
||||
-- Object information --
|
||||
------------------------
|
||||
|
||||
function Arch (Obj : Object_File) return Object_Arch;
|
||||
-- Return the object architecture
|
||||
|
||||
function Format (Obj : Object_File) return Object_Format;
|
||||
-- Return the object file format
|
||||
|
||||
function Get_Load_Address (Obj : Object_File) return uint64;
|
||||
-- Return the load address defined in Obj. May raise Format_Error if not
|
||||
-- implemented
|
||||
|
||||
function Num_Sections (Obj : Object_File) return uint32;
|
||||
-- Return the number of sections composing the object file
|
||||
|
||||
function Get_Section
|
||||
(Obj : in out Object_File;
|
||||
Shnum : uint32) return Object_Section;
|
||||
-- Return the Nth section (numbered from zero)
|
||||
|
||||
function Get_Section
|
||||
(Obj : in out Object_File;
|
||||
Sec_Name : String) return Object_Section;
|
||||
-- Return a section by name
|
||||
|
||||
function Create_Stream
|
||||
(Obj : Object_File;
|
||||
Sec : Object_Section) return Mapped_Stream;
|
||||
-- Create a stream for section Sec
|
||||
|
||||
procedure Get_Memory_Bounds
|
||||
(Obj : in out Object_File;
|
||||
Low, High : out uint64);
|
||||
-- Return the low and high addresses of the code for the object file. Can
|
||||
-- be used to check if an address in within this object file. This
|
||||
-- procedure is not efficient and the result should be saved to avoid
|
||||
-- recomputation.
|
||||
|
||||
-------------------------
|
||||
-- Section information --
|
||||
-------------------------
|
||||
|
||||
function Name
|
||||
(Obj : in out Object_File;
|
||||
Sec : Object_Section) return String;
|
||||
-- Return the name of a section as a string
|
||||
|
||||
function Size (Sec : Object_Section) return uint64;
|
||||
-- Return the size of a section in bytes
|
||||
|
||||
function Num (Sec : Object_Section) return uint32;
|
||||
-- Return the index of a section from zero
|
||||
|
||||
function Off (Sec : Object_Section) return Offset;
|
||||
-- Return the byte offset of the section within the object
|
||||
|
||||
------------------------------
|
||||
-- Symbol table information --
|
||||
------------------------------
|
||||
|
||||
Null_Symbol : constant Object_Symbol;
|
||||
-- An empty symbol table entry.
|
||||
|
||||
function First_Symbol (Obj : in out Object_File) return Object_Symbol;
|
||||
-- Return the first element in the symbol table or Null_Symbol if the
|
||||
-- symbol table is empty.
|
||||
|
||||
function Next_Symbol
|
||||
(Obj : in out Object_File;
|
||||
Prev : Object_Symbol) return Object_Symbol;
|
||||
-- Return the element following Prev in the symbol table, or Null_Symbol if
|
||||
-- Prev is the last symbol in the table.
|
||||
|
||||
function Read_Symbol
|
||||
(Obj : in out Object_File;
|
||||
Off : Offset) return Object_Symbol;
|
||||
-- Read symbol at Off
|
||||
|
||||
function Name
|
||||
(Obj : in out Object_File;
|
||||
Sym : Object_Symbol) return String_Ptr_Len;
|
||||
-- Return the name of the symbol
|
||||
|
||||
function Decoded_Ada_Name
|
||||
(Obj : in out Object_File;
|
||||
Sym : String_Ptr_Len) return String;
|
||||
-- Return the decoded name of a symbol encoded as per exp_dbug.ads
|
||||
|
||||
function Strip_Leading_Char
|
||||
(Obj : in out Object_File;
|
||||
Sym : String_Ptr_Len) return Positive;
|
||||
-- Return the index of the first character to decode the name. This can
|
||||
-- strip one character for ABI with a prefix (like x86 for PECOFF).
|
||||
|
||||
function Value (Sym : Object_Symbol) return uint64;
|
||||
-- Return the name of the symbol
|
||||
|
||||
function Size (Sym : Object_Symbol) return uint64;
|
||||
-- Return the size of the symbol in bytes
|
||||
|
||||
function Spans (Sym : Object_Symbol; Addr : uint64) return Boolean;
|
||||
-- Determine whether a particular address corresponds to the range
|
||||
-- referenced by this symbol.
|
||||
|
||||
function Off (Sym : Object_Symbol) return Offset;
|
||||
-- Return the offset of the symbol.
|
||||
|
||||
----------------
|
||||
-- Exceptions --
|
||||
----------------
|
||||
|
||||
IO_Error : exception;
|
||||
-- Input/Output error reading file
|
||||
|
||||
Format_Error : exception;
|
||||
-- Encountered a problem parsing the object
|
||||
|
||||
private
|
||||
type Mapped_Stream is record
|
||||
Region : System.Mmap.Mapped_Region;
|
||||
Off : Offset;
|
||||
Len : Offset;
|
||||
end record;
|
||||
|
||||
subtype ELF is Object_Format range ELF32 .. ELF64;
|
||||
subtype Any_PECOFF is Object_Format range PECOFF .. PECOFF_PLUS;
|
||||
|
||||
type Object_File (Format : Object_Format) is record
|
||||
Mf : System.Mmap.Mapped_File :=
|
||||
System.Mmap.Invalid_Mapped_File;
|
||||
Arch : Object_Arch := Unknown;
|
||||
|
||||
Num_Sections : uint32 := 0;
|
||||
-- Number of sections
|
||||
|
||||
Symtab_Last : Offset; -- Last offset of symbol table
|
||||
|
||||
In_Exception : Boolean := False;
|
||||
-- True if the parsing is done as part of an exception handler
|
||||
|
||||
Sectab_Stream : Mapped_Stream;
|
||||
-- Section table
|
||||
|
||||
Symtab_Stream : Mapped_Stream;
|
||||
-- Symbol table
|
||||
|
||||
Symstr_Stream : Mapped_Stream;
|
||||
-- Symbol strings
|
||||
|
||||
case Format is
|
||||
when ELF =>
|
||||
Secstr_Stream : Mapped_Stream;
|
||||
-- Section strings
|
||||
when Any_PECOFF =>
|
||||
ImageBase : uint64; -- ImageBase value from header
|
||||
|
||||
-- Cache for latest result of Get_Section_Virtual_Address
|
||||
|
||||
GSVA_Sec : uint32 := uint32'Last;
|
||||
GSVA_Addr : uint64;
|
||||
when XCOFF32 =>
|
||||
null;
|
||||
end case;
|
||||
end record;
|
||||
|
||||
subtype ELF_Object_File is Object_File; -- with
|
||||
-- Predicate => ELF_Object_File.Format in ELF;
|
||||
subtype PECOFF_Object_File is Object_File; -- with
|
||||
-- Predicate => PECOFF_Object_File.Format in Any_PECOFF;
|
||||
subtype XCOFF32_Object_File is Object_File; -- with
|
||||
-- Predicate => XCOFF32_Object_File.Format in XCOFF32;
|
||||
-- ???Above predicates cause the compiler to crash when instantiating
|
||||
-- ELF64_Ops (see package body).
|
||||
|
||||
type Object_Section is record
|
||||
Num : uint32 := 0;
|
||||
-- Section index in the section table
|
||||
|
||||
Off : Offset := 0;
|
||||
-- First byte of the section in the object file
|
||||
|
||||
Addr : uint64 := 0;
|
||||
-- Load address of the section. Valid only when Flag_Alloc is true.
|
||||
|
||||
Size : uint64 := 0;
|
||||
-- Length of the section in bytes
|
||||
|
||||
Flag_Alloc : Boolean := False;
|
||||
-- True if the section is mapped in memory by the OS loader
|
||||
end record;
|
||||
|
||||
Null_Section : constant Object_Section := (0, 0, 0, 0, False);
|
||||
|
||||
type Object_Symbol is record
|
||||
Off : Offset := 0; -- Offset of underlying symbol on disk
|
||||
Next : Offset := 0; -- Offset of the following symbol
|
||||
Value : uint64 := 0; -- Value associated with this symbol
|
||||
Size : uint64 := 0; -- Size of the referenced entity
|
||||
end record;
|
||||
|
||||
Null_Symbol : constant Object_Symbol := (0, 0, 0, 0);
|
||||
end System.Object_Reader;
|
||||
|
|
@ -0,0 +1,689 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- 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-2017, 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
|
||||
|
||||
pragma Polling (Off);
|
||||
-- We must turn polling off for this unit, because otherwise we can get
|
||||
-- elaboration circularities when polling is turned on.
|
||||
|
||||
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);
|
||||
-- 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 : access System.Address) return String;
|
||||
-- Returns the module name for the given address, Addr may be updated
|
||||
-- to be set relative to a shared library. This depends on the platform.
|
||||
-- Returns an empty string for the main executable.
|
||||
|
||||
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 or if argv[0] executable not found in path, function returns
|
||||
-- an empty string.
|
||||
|
||||
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) is
|
||||
Module : Module_Cache_Acc;
|
||||
Success : Boolean;
|
||||
begin
|
||||
Module := new Module_Cache;
|
||||
Init_Module (Module.all, Success, Module_Name);
|
||||
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 (Left.C) < Low (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;
|
||||
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;
|
||||
|
||||
declare
|
||||
Addr : constant System.Address :=
|
||||
locate_exec_on_path (Conv.To_Pointer (Gnat_Argv) (0));
|
||||
Result : constant String := Value (Addr);
|
||||
|
||||
begin
|
||||
-- The buffer returned by locate_exec_on_path was allocated using
|
||||
-- malloc, so we should use free to release the memory.
|
||||
|
||||
if Addr /= Null_Address then
|
||||
System.CRTL.free (Addr);
|
||||
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 := False;
|
||||
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 (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
|
||||
Addr : aliased System.Address := Traceback (F);
|
||||
M_Name : constant String := Module_Name.Get (Addr'Access);
|
||||
Module : Module_Cache;
|
||||
Success : Boolean;
|
||||
begin
|
||||
Init_Module (Module, Success, M_Name, System.Null_Address);
|
||||
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 : 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;
|
||||
|
|
@ -0,0 +1,190 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2012-2017, 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. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the GNU/Linux specific version of this package
|
||||
with Interfaces.C; use Interfaces.C;
|
||||
|
||||
with System.Address_Operations; use System.Address_Operations;
|
||||
|
||||
separate (System.Traceback.Symbolic)
|
||||
|
||||
package body Module_Name is
|
||||
|
||||
use System;
|
||||
|
||||
pragma Linker_Options ("-ldl");
|
||||
|
||||
function Is_Shared_Lib (Base : Address) return Boolean;
|
||||
-- Returns True if a shared library
|
||||
|
||||
-- The principle is:
|
||||
|
||||
-- 1. We get information about the module containing the address.
|
||||
|
||||
-- 2. We check that the full pathname is pointing to a shared library.
|
||||
|
||||
-- 3. for shared libraries, we return the non relocated address (so
|
||||
-- the absolute address in the shared library).
|
||||
|
||||
-- 4. we also return the full pathname of the module containing this
|
||||
-- address.
|
||||
|
||||
-------------------
|
||||
-- Is_Shared_Lib --
|
||||
-------------------
|
||||
|
||||
function Is_Shared_Lib (Base : Address) return Boolean is
|
||||
EI_NIDENT : constant := 16;
|
||||
type u16 is mod 2 ** 16;
|
||||
|
||||
-- Just declare the needed header information, we just need to read the
|
||||
-- type encoded in the second field.
|
||||
|
||||
type Elf32_Ehdr is record
|
||||
e_ident : char_array (1 .. EI_NIDENT);
|
||||
e_type : u16;
|
||||
end record;
|
||||
|
||||
ET_DYN : constant := 3; -- A shared lib if e_type = ET_DYN
|
||||
|
||||
Header : Elf32_Ehdr;
|
||||
pragma Import (Ada, Header);
|
||||
-- Suppress initialization in Normalized_Scalars mode
|
||||
for Header'Address use Base;
|
||||
|
||||
begin
|
||||
return Header.e_type = ET_DYN;
|
||||
exception
|
||||
when others =>
|
||||
return False;
|
||||
end Is_Shared_Lib;
|
||||
|
||||
---------------------------------
|
||||
-- Build_Cache_For_All_Modules --
|
||||
---------------------------------
|
||||
|
||||
procedure Build_Cache_For_All_Modules is
|
||||
type link_map;
|
||||
type link_map_acc is access all link_map;
|
||||
pragma Convention (C, link_map_acc);
|
||||
|
||||
type link_map is record
|
||||
l_addr : Address;
|
||||
-- Base address of the shared object
|
||||
|
||||
l_name : Address;
|
||||
-- Null-terminated absolute file name
|
||||
|
||||
l_ld : Address;
|
||||
-- Dynamic section
|
||||
|
||||
l_next, l_prev : link_map_acc;
|
||||
-- Chain
|
||||
end record;
|
||||
pragma Convention (C, link_map);
|
||||
|
||||
type r_debug_type is record
|
||||
r_version : Integer;
|
||||
r_map : link_map_acc;
|
||||
end record;
|
||||
pragma Convention (C, r_debug_type);
|
||||
|
||||
r_debug : r_debug_type;
|
||||
pragma Import (C, r_debug, "_r_debug");
|
||||
|
||||
lm : link_map_acc;
|
||||
begin
|
||||
lm := r_debug.r_map;
|
||||
while lm /= null loop
|
||||
if Big_String_Conv.To_Pointer (lm.l_name) (1) /= ASCII.NUL then
|
||||
-- Discard non-file (like the executable itself or the gate).
|
||||
Add_Module_To_Cache (Value (lm.l_name));
|
||||
end if;
|
||||
lm := lm.l_next;
|
||||
end loop;
|
||||
end Build_Cache_For_All_Modules;
|
||||
|
||||
---------
|
||||
-- Get --
|
||||
---------
|
||||
|
||||
function Get (Addr : access System.Address) return String is
|
||||
|
||||
-- Dl_info record for Linux, used to get sym reloc offset
|
||||
|
||||
type Dl_info is record
|
||||
dli_fname : System.Address;
|
||||
dli_fbase : System.Address;
|
||||
dli_sname : System.Address;
|
||||
dli_saddr : System.Address;
|
||||
end record;
|
||||
|
||||
function dladdr
|
||||
(addr : System.Address;
|
||||
info : not null access Dl_info) return int;
|
||||
pragma Import (C, dladdr, "dladdr");
|
||||
-- This is a Linux extension and not POSIX
|
||||
|
||||
info : aliased Dl_info;
|
||||
|
||||
begin
|
||||
if dladdr (Addr.all, info'Access) /= 0 then
|
||||
|
||||
-- If we have a shared library we need to adjust the address to
|
||||
-- be relative to the base address of the library.
|
||||
|
||||
if Is_Shared_Lib (info.dli_fbase) then
|
||||
Addr.all := SubA (Addr.all, info.dli_fbase);
|
||||
end if;
|
||||
|
||||
return Value (info.dli_fname);
|
||||
|
||||
-- Not found, fallback to executable name
|
||||
|
||||
else
|
||||
return "";
|
||||
end if;
|
||||
|
||||
exception
|
||||
when others =>
|
||||
return "";
|
||||
end Get;
|
||||
|
||||
------------------
|
||||
-- Is_Supported --
|
||||
------------------
|
||||
|
||||
function Is_Supported return Boolean is
|
||||
begin
|
||||
return True;
|
||||
end Is_Supported;
|
||||
|
||||
end Module_Name;
|
||||
|
|
@ -0,0 +1,93 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2012-2017, 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. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the Windows specific version of this package
|
||||
|
||||
with System.Win32; use System.Win32;
|
||||
|
||||
separate (System.Traceback.Symbolic)
|
||||
|
||||
package body Module_Name is
|
||||
|
||||
use System;
|
||||
|
||||
---------------------------------
|
||||
-- Build_Cache_For_All_Modules --
|
||||
---------------------------------
|
||||
|
||||
procedure Build_Cache_For_All_Modules is
|
||||
begin
|
||||
null;
|
||||
end Build_Cache_For_All_Modules;
|
||||
|
||||
---------
|
||||
-- Get --
|
||||
---------
|
||||
|
||||
function Get (Addr : access System.Address) return String is
|
||||
Res : DWORD;
|
||||
hModule : aliased HANDLE;
|
||||
Path : String (1 .. 1_024);
|
||||
|
||||
begin
|
||||
if GetModuleHandleEx
|
||||
(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
|
||||
Addr.all,
|
||||
hModule'Access) = Win32.TRUE
|
||||
then
|
||||
Res := GetModuleFileName (hModule, Path'Address, Path'Length);
|
||||
|
||||
if FreeLibrary (hModule) = Win32.FALSE then
|
||||
null;
|
||||
end if;
|
||||
|
||||
if Res > 0 then
|
||||
return Path (1 .. Positive (Res));
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return "";
|
||||
|
||||
exception
|
||||
when others =>
|
||||
return "";
|
||||
end Get;
|
||||
|
||||
------------------
|
||||
-- Is_Supported --
|
||||
------------------
|
||||
|
||||
function Is_Supported return Boolean is
|
||||
begin
|
||||
return True;
|
||||
end Is_Supported;
|
||||
|
||||
end Module_Name;
|
||||
Loading…
Reference in New Issue