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:
parent
6a237c4530
commit
a2529c0aa7
|
@ -429,6 +429,25 @@ X86_64_TARGET_PAIRS = \
|
||||||
a-numaux.adb<a-numaux-x86.adb \
|
a-numaux.adb<a-numaux-x86.adb \
|
||||||
s-atocou.adb<s-atocou-builtin.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
|
# Shared library version
|
||||||
LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)ada/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/'))
|
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-inmaop.adb<s-inmaop-posix.adb \
|
||||||
s-intman.adb<s-intman-posix.adb \
|
s-intman.adb<s-intman-posix.adb \
|
||||||
s-tpopsp.adb<s-tpopsp-tls.adb \
|
s-tpopsp.adb<s-tpopsp-tls.adb \
|
||||||
|
$(TRASYM_DWARF_UNIX_PAIRS) \
|
||||||
g-sercom.adb<g-sercom-linux.adb \
|
g-sercom.adb<g-sercom-linux.adb \
|
||||||
|
s-tsmona.adb<s-tsmona-linux.adb \
|
||||||
a-exetim.adb<a-exetim-posix.adb \
|
a-exetim.adb<a-exetim-posix.adb \
|
||||||
a-exetim.ads<a-exetim-default.ads \
|
a-exetim.ads<a-exetim-default.ads \
|
||||||
s-linux.ads<s-linux.ads \
|
s-linux.ads<s-linux.ads \
|
||||||
|
@ -1111,6 +1132,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),)
|
||||||
EH_MECHANISM=-gcc
|
EH_MECHANISM=-gcc
|
||||||
THREADSLIB = -lpthread -lrt
|
THREADSLIB = -lpthread -lrt
|
||||||
EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
|
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
|
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
|
||||||
|
|
||||||
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
|
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-tpopsp.adb<s-tpopsp-tls.adb \
|
||||||
s-taspri.ads<s-taspri-posix.ads \
|
s-taspri.ads<s-taspri-posix.ads \
|
||||||
g-sercom.adb<g-sercom-linux.adb \
|
g-sercom.adb<g-sercom-linux.adb \
|
||||||
|
$(TRASYM_DWARF_UNIX_PAIRS) \
|
||||||
|
s-tsmona.adb<s-tsmona-linux.adb \
|
||||||
$(ATOMICS_TARGET_PAIRS) \
|
$(ATOMICS_TARGET_PAIRS) \
|
||||||
$(X86_64_TARGET_PAIRS) \
|
$(X86_64_TARGET_PAIRS) \
|
||||||
system.ads<system-linux-x86.ads
|
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
|
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
|
||||||
|
|
||||||
EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
|
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
|
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
|
||||||
|
|
||||||
EH_MECHANISM=-gcc
|
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