Skip to content

R
riscv-gcc-1
Commit a2529c0a by Arnaud Charlet
Options

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
parent 6a237c45
Showing with 5512 additions and 0 deletions
gcc/ada/gcc-interface/Makefile.in
......@@ -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
......
gcc/ada/s-dwalin.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . D W A R F _ L I N E S --
-- --
-- B o d y --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
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.Characters.Handling;
with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
with Ada.Unchecked_Deallocation;
with Ada.Containers.Generic_Array_Sort;
with Interfaces; use Interfaces;
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
with System.Address_Image;
with System.IO; use System.IO;
with System.Object_Reader; use System.Object_Reader;
with System.Traceback_Entries; use System.Traceback_Entries;
with System.Mmap; use System.Mmap;
with System.Bounded_Strings; use System.Bounded_Strings;
package body System.Dwarf_Lines is
SSU : constant := System.Storage_Unit;
function String_Length (Str : Str_Access) return Natural;
-- Return the length of the C string Str
---------------------------------
-- DWARF Parser Implementation --
---------------------------------
procedure Read_Initial_Length
(S : in out Mapped_Stream;
Len : out Offset;
Is64 : out Boolean);
-- Read initial length as specified by Dwarf-4 7.2.2
procedure Read_Section_Offset
(S : in out Mapped_Stream;
Len : out Offset;
Is64 : Boolean);
-- Read a section offset, as specified by Dwarf-4 7.4
procedure Read_Aranges_Entry
(C : in out Dwarf_Context;
Start : out Integer_Address;
Len : out Storage_Count);
-- Read a single .debug_aranges pair
procedure Read_Aranges_Header
(C : in out Dwarf_Context;
Info_Offset : out Offset;
Success : out Boolean);
-- Read .debug_aranges header
procedure Aranges_Lookup
(C : in out Dwarf_Context;
Addr : Address;
Info_Offset : out Offset;
Success : out Boolean);
-- Search for Addr in .debug_aranges and return offset Info_Offset in
-- .debug_info.
procedure Skip_Form
(S : in out Mapped_Stream;
Form : uint32;
Is64 : Boolean;
Ptr_Sz : uint8);
-- Advance offset in S for Form.
procedure Seek_Abbrev
(C : in out Dwarf_Context;
Abbrev_Offset : Offset;
Abbrev_Num : uint32);
-- Seek to abbrev Abbrev_Num (starting from Abbrev_Offset)
procedure Debug_Info_Lookup
(C : in out Dwarf_Context;
Info_Offset : Offset;
Line_Offset : out Offset;
Success : out Boolean);
-- Search for stmt_list tag in Info_Offset and set Line_Offset to the
-- offset in .debug_lines. Only look at the first DIE, which should be
-- a compilation unit.
procedure Initialize_Pass (C : in out Dwarf_Context);
-- Seek to the first byte of the first prologue and prepare to make a pass
-- over the line number entries.
procedure Initialize_State_Machine (C : in out Dwarf_Context);
-- Set all state machine registers to their specified initial values
procedure Parse_Prologue (C : in out Dwarf_Context);
-- Decode a DWARF statement program prologue
procedure Read_And_Execute_Isn
(C : in out Dwarf_Context;
Done : out Boolean);
-- Read an execute a statement program instruction
function To_File_Name
(C : in out Dwarf_Context;
Code : uint32) return String;
-- Extract a file name from the prologue
type Callback is access procedure (C : in out Dwarf_Context);
procedure For_Each_Row (C : in out Dwarf_Context; F : Callback);
-- Traverse each .debug_line entry with a callback
procedure Dump_Row (C : in out Dwarf_Context);
-- Dump a single row
function "<" (Left, Right : Search_Entry) return Boolean;
-- For sorting Search_Entry
procedure Sort_Search_Array is new Ada.Containers.Generic_Array_Sort
(Index_Type => Natural,
Element_Type => Search_Entry,
Array_Type => Search_Array);
procedure Symbolic_Address
(C : in out Dwarf_Context;
Addr : Address;
Dir_Name : out Str_Access;
File_Name : out Str_Access;
Subprg_Name : out String_Ptr_Len;
Line_Num : out Natural);
-- Symbolize one address
-----------------------
-- DWARF constants --
-----------------------
-- 6.2.5.2 Standard Opcodes
DW_LNS_copy : constant := 1;
DW_LNS_advance_pc : constant := 2;
DW_LNS_advance_line : constant := 3;
DW_LNS_set_file : constant := 4;
DW_LNS_set_column : constant := 5;
DW_LNS_negate_stmt : constant := 6;
DW_LNS_set_basic_block : constant := 7;
DW_LNS_const_add_pc : constant := 8;
DW_LNS_fixed_advance_pc : constant := 9;
DW_LNS_set_prologue_end : constant := 10;
DW_LNS_set_epilogue_begin : constant := 11;
DW_LNS_set_isa : constant := 12;
-- 6.2.5.3 Extended Opcodes
DW_LNE_end_sequence : constant := 1;
DW_LNE_set_address : constant := 2;
DW_LNE_define_file : constant := 3;
-- From the DWARF version 4 public review draft
DW_LNE_set_discriminator : constant := 4;
-- Attribute encodings
DW_TAG_Compile_Unit : constant := 16#11#;
DW_AT_Stmt_List : constant := 16#10#;
DW_FORM_addr : constant := 16#01#;
DW_FORM_block2 : constant := 16#03#;
DW_FORM_block4 : constant := 16#04#;
DW_FORM_data2 : constant := 16#05#;
DW_FORM_data4 : constant := 16#06#;
DW_FORM_data8 : constant := 16#07#;
DW_FORM_string : constant := 16#08#;
DW_FORM_block : constant := 16#09#;
DW_FORM_block1 : constant := 16#0a#;
DW_FORM_data1 : constant := 16#0b#;
DW_FORM_flag : constant := 16#0c#;
DW_FORM_sdata : constant := 16#0d#;
DW_FORM_strp : constant := 16#0e#;
DW_FORM_udata : constant := 16#0f#;
DW_FORM_ref_addr : constant := 16#10#;
DW_FORM_ref1 : constant := 16#11#;
DW_FORM_ref2 : constant := 16#12#;
DW_FORM_ref4 : constant := 16#13#;
DW_FORM_ref8 : constant := 16#14#;
DW_FORM_ref_udata : constant := 16#15#;
DW_FORM_indirect : constant := 16#16#;
DW_FORM_sec_offset : constant := 16#17#;
DW_FORM_exprloc : constant := 16#18#;
DW_FORM_flag_present : constant := 16#19#;
DW_FORM_ref_sig8 : constant := 16#20#;
---------
-- "<" --
---------
function "<" (Left, Right : Search_Entry) return Boolean is
begin
return Left.First < Right.First;
end "<";
-----------
-- Close --
-----------
procedure Close (C : in out Dwarf_Context) is
procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
(Object_File,
Object_File_Access);
procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
(Search_Array,
Search_Array_Access);
begin
if C.Has_Debug then
Close (C.Lines);
Close (C.Abbrev);
Close (C.Info);
Close (C.Aranges);
end if;
Close (C.Obj.all);
Unchecked_Deallocation (C.Obj);
Unchecked_Deallocation (C.Cache);
end Close;
----------
-- Dump --
----------
procedure Dump (C : in out Dwarf_Context) is
begin
For_Each_Row (C, Dump_Row'Access);
end Dump;
--------------
-- Dump_Row --
--------------
procedure Dump_Row (C : in out Dwarf_Context) is
PC : constant Integer_Address := Integer_Address (C.Registers.Address);
Off : Offset;
begin
Tell (C.Lines, Off);
Put (System.Address_Image (To_Address (PC)));
Put (" ");
Put (To_File_Name (C, C.Registers.File));
Put (":");
declare
Image : constant String := uint32'Image (C.Registers.Line);
begin
Put_Line (Image (2 .. Image'Last));
end;
Seek (C.Lines, Off);
end Dump_Row;
procedure Dump_Cache (C : Dwarf_Context) is
Cache : constant Search_Array_Access := C.Cache;
S : Object_Symbol;
Name : String_Ptr_Len;
begin
if Cache = null then
Put_Line ("No cache");
return;
end if;
for I in Cache'Range loop
Put (System.Address_Image (C.Low + Storage_Count (Cache (I).First)));
Put (" - ");
Put
(System.Address_Image
(C.Low + Storage_Count (Cache (I).First + Cache (I).Size)));
Put (" l@");
Put
(System.Address_Image
(To_Address (Integer_Address (Cache (I).Line))));
Put (": ");
S := Read_Symbol (C.Obj.all, Offset (Cache (I).Sym));
Name := Object_Reader.Name (C.Obj.all, S);
Put (String (Name.Ptr (1 .. Name.Len)));
New_Line;
end loop;
end Dump_Cache;
------------------
-- For_Each_Row --
------------------
procedure For_Each_Row (C : in out Dwarf_Context; F : Callback) is
Done : Boolean;
begin
Initialize_Pass (C);
loop
Read_And_Execute_Isn (C, Done);
if C.Registers.Is_Row then
F.all (C);
end if;
exit when Done;
end loop;
end For_Each_Row;
---------------------
-- Initialize_Pass --
---------------------
procedure Initialize_Pass (C : in out Dwarf_Context) is
begin
Seek (C.Lines, 0);
C.Next_Prologue := 0;
Initialize_State_Machine (C);
end Initialize_Pass;
------------------------------
-- Initialize_State_Machine --
------------------------------
procedure Initialize_State_Machine (C : in out Dwarf_Context) is
begin
C.Registers :=
(Address => 0,
File => 1,
Line => 1,
Column => 0,
Is_Stmt => C.Prologue.Default_Is_Stmt = 0,
Basic_Block => False,
End_Sequence => False,
Prologue_End => False,
Epilogue_Begin => False,
ISA => 0,
Is_Row => False);
end Initialize_State_Machine;
---------------
-- Is_Inside --
---------------
function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is
begin
return Addr >= C.Low and Addr <= C.High;
end Is_Inside;
---------
-- Low --
---------
function Low (C : Dwarf_Context) return Address is
begin
return C.Low;
end Low;
----------
-- Open --
----------
procedure Open
(File_Name : String;
C : out Dwarf_Context;
Success : out Boolean)
is
Line_Sec, Info_Sec, Abbrev_Sec, Aranges_Sec : Object_Section;
Hi, Lo : uint64;
begin
-- Not a success by default
Success := False;
-- Open file
C.Obj := Open (File_Name, C.In_Exception);
if C.Obj = null then
return;
end if;
Success := True;
-- Get memory bounds
Get_Memory_Bounds (C.Obj.all, Lo, Hi);
C.Low := Address (Lo);
C.High := Address (Hi);
-- Create a stream for debug sections
if Format (C.Obj.all) = XCOFF32 then
Line_Sec := Get_Section (C.Obj.all, ".dwline");
Abbrev_Sec := Get_Section (C.Obj.all, ".dwabrev");
Info_Sec := Get_Section (C.Obj.all, ".dwinfo");
Aranges_Sec := Get_Section (C.Obj.all, ".dwarnge");
else
Line_Sec := Get_Section (C.Obj.all, ".debug_line");
Abbrev_Sec := Get_Section (C.Obj.all, ".debug_abbrev");
Info_Sec := Get_Section (C.Obj.all, ".debug_info");
Aranges_Sec := Get_Section (C.Obj.all, ".debug_aranges");
end if;
if Line_Sec = Null_Section
or else Abbrev_Sec = Null_Section
or else Info_Sec = Null_Section
or else Aranges_Sec = Null_Section
then
C.Has_Debug := False;
return;
end if;
C.Lines := Create_Stream (C.Obj.all, Line_Sec);
C.Abbrev := Create_Stream (C.Obj.all, Abbrev_Sec);
C.Info := Create_Stream (C.Obj.all, Info_Sec);
C.Aranges := Create_Stream (C.Obj.all, Aranges_Sec);
-- All operations are successful, context is valid
C.Has_Debug := True;
end Open;
--------------------
-- Parse_Prologue --
--------------------
procedure Parse_Prologue (C : in out Dwarf_Context) is
Char : uint8;
Prev : uint8;
-- The most recently read character and the one preceding it
Dummy : uint32;
-- Destination for reads we don't care about
Buf : Buffer;
Off : Offset;
First_Byte_Of_Prologue : Offset;
Last_Byte_Of_Prologue : Offset;
Max_Op_Per_Insn : uint8;
pragma Unreferenced (Max_Op_Per_Insn);
Prologue : Line_Info_Prologue renames C.Prologue;
begin
Tell (C.Lines, First_Byte_Of_Prologue);
Prologue.Unit_Length := Read (C.Lines);
Tell (C.Lines, Off);
C.Next_Prologue := Off + Offset (Prologue.Unit_Length);
Prologue.Version := Read (C.Lines);
Prologue.Prologue_Length := Read (C.Lines);
Tell (C.Lines, Last_Byte_Of_Prologue);
Last_Byte_Of_Prologue :=
Last_Byte_Of_Prologue + Offset (Prologue.Prologue_Length) - 1;
Prologue.Min_Isn_Length := Read (C.Lines);
if Prologue.Version >= 4 then
Max_Op_Per_Insn := Read (C.Lines);
end if;
Prologue.Default_Is_Stmt := Read (C.Lines);
Prologue.Line_Base := Read (C.Lines);
Prologue.Line_Range := Read (C.Lines);
Prologue.Opcode_Base := Read (C.Lines);
-- Opcode_Lengths is an array of Opcode_Base bytes specifying the number
-- of LEB128 operands for each of the standard opcodes.
for J in 1 .. uint32 (Prologue.Opcode_Base - 1) loop
Prologue.Opcode_Lengths (J) := Read (C.Lines);
end loop;
-- The include directories table follows. This is a list of null
-- terminated strings terminated by a double null. We only store
-- its offset for later decoding.
Tell (C.Lines, Prologue.Includes_Offset);
Char := Read (C.Lines);
if Char /= 0 then
loop
Prev := Char;
Char := Read (C.Lines);
exit when Char = 0 and Prev = 0;
end loop;
end if;
-- The file_names table is next. Each record is a null terminated string
-- for the file name, an unsigned LEB128 directory index, an unsigned
-- LEB128 modification time, and an LEB128 file length. The table is
-- terminated by a null byte.
Tell (C.Lines, Prologue.File_Names_Offset);
loop
-- Read the filename
Read_C_String (C.Lines, Buf);
exit when Buf (0) = 0;
Dummy := Read_LEB128 (C.Lines); -- Skip the directory index.
Dummy := Read_LEB128 (C.Lines); -- Skip the modification time.
Dummy := Read_LEB128 (C.Lines); -- Skip the file length.
end loop;
-- Check we're where we think we are. This sanity check ensures we think
-- the prologue ends where the prologue says it does. It we aren't then
-- we've probably gotten out of sync somewhere.
Tell (C.Lines, Off);
if Prologue.Unit_Length /= 0
and then Off /= Last_Byte_Of_Prologue + 1
then
raise Dwarf_Error with "Parse error reading DWARF information";
end if;
end Parse_Prologue;
--------------------------
-- Read_And_Execute_Isn --
--------------------------
procedure Read_And_Execute_Isn
(C : in out Dwarf_Context;
Done : out Boolean)
is
Opcode : uint8;
Extended_Opcode : uint8;
uint32_Operand : uint32;
int32_Operand : int32;
uint16_Operand : uint16;
Off : Offset;
Extended_Length : uint32;
pragma Unreferenced (Extended_Length);
Obj : Object_File renames C.Obj.all;
Registers : Line_Info_Registers renames C.Registers;
Prologue : Line_Info_Prologue renames C.Prologue;
begin
Done := False;
Registers.Is_Row := False;
if Registers.End_Sequence then
Initialize_State_Machine (C);
end if;
-- Read the next prologue
Tell (C.Lines, Off);
while Off = C.Next_Prologue loop
Initialize_State_Machine (C);
Parse_Prologue (C);
Tell (C.Lines, Off);
exit when Off + 4 >= Length (C.Lines);
end loop;
-- Test whether we're done
Tell (C.Lines, Off);
-- We are finished when we either reach the end of the section, or we
-- have reached zero padding at the end of the section.
if Prologue.Unit_Length = 0 or else Off + 4 >= Length (C.Lines) then
Done := True;
return;
end if;
-- Read and interpret an instruction
Opcode := Read (C.Lines);
-- Extended opcodes
if Opcode = 0 then
Extended_Length := Read_LEB128 (C.Lines);
Extended_Opcode := Read (C.Lines);
case Extended_Opcode is
when DW_LNE_end_sequence =>
-- Mark the end of a sequence of source locations
Registers.End_Sequence := True;
Registers.Is_Row := True;
when DW_LNE_set_address =>
-- Set the program counter to a word
Registers.Address := Read_Address (Obj, C.Lines);
when DW_LNE_define_file =>
-- Not implemented
raise Dwarf_Error with "DWARF operator not implemented";
when DW_LNE_set_discriminator =>
-- Ignored
int32_Operand := Read_LEB128 (C.Lines);
when others =>
-- Fail on an unrecognized opcode
raise Dwarf_Error with "DWARF operator not implemented";
end case;
-- Standard opcodes
elsif Opcode < Prologue.Opcode_Base then
case Opcode is
-- Append a row to the line info matrix
when DW_LNS_copy =>
Registers.Basic_Block := False;
Registers.Is_Row := True;
-- Add an unsigned word to the program counter
when DW_LNS_advance_pc =>
uint32_Operand := Read_LEB128 (C.Lines);
Registers.Address :=
Registers.Address +
uint64 (uint32_Operand * uint32 (Prologue.Min_Isn_Length));
-- Add a signed word to the current source line
when DW_LNS_advance_line =>
int32_Operand := Read_LEB128 (C.Lines);
Registers.Line :=
uint32 (int32 (Registers.Line) + int32_Operand);
-- Set the current source file
when DW_LNS_set_file =>
uint32_Operand := Read_LEB128 (C.Lines);
Registers.File := uint32_Operand;
-- Set the current source column
when DW_LNS_set_column =>
uint32_Operand := Read_LEB128 (C.Lines);
Registers.Column := uint32_Operand;
-- Toggle the "is statement" flag. GCC doesn't seem to set this???
when DW_LNS_negate_stmt =>
Registers.Is_Stmt := not Registers.Is_Stmt;
-- Mark the beginning of a basic block
when DW_LNS_set_basic_block =>
Registers.Basic_Block := True;
-- Advance the program counter as by the special opcode 255
when DW_LNS_const_add_pc =>
Registers.Address :=
Registers.Address +
uint64
(((255 - Prologue.Opcode_Base) / Prologue.Line_Range) *
Prologue.Min_Isn_Length);
-- Advance the program counter by a constant
when DW_LNS_fixed_advance_pc =>
uint16_Operand := Read (C.Lines);
Registers.Address :=
Registers.Address + uint64 (uint16_Operand);
-- The following are not implemented and ignored
when DW_LNS_set_prologue_end =>
null;
when DW_LNS_set_epilogue_begin =>
null;
when DW_LNS_set_isa =>
null;
-- Anything else is an error
when others =>
raise Dwarf_Error with "DWARF operator not implemented";
end case;
-- Decode a special opcode. This is a line and address increment encoded
-- in a single byte 'special opcode' as described in 6.2.5.1.
else
declare
Address_Increment : int32;
Line_Increment : int32;
begin
Opcode := Opcode - Prologue.Opcode_Base;
-- The adjusted opcode is a uint8 encoding an address increment
-- and a signed line increment. The upperbound is allowed to be
-- greater than int8'last so we decode using int32 directly to
-- prevent overflows.
Address_Increment :=
int32 (Opcode / Prologue.Line_Range) *
int32 (Prologue.Min_Isn_Length);
Line_Increment :=
int32 (Prologue.Line_Base) +
int32 (Opcode mod Prologue.Line_Range);
Registers.Address :=
Registers.Address + uint64 (Address_Increment);
Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment);
Registers.Basic_Block := False;
Registers.Prologue_End := False;
Registers.Epilogue_Begin := False;
Registers.Is_Row := True;
end;
end if;
exception
when Dwarf_Error =>
-- In case of errors during parse, just stop reading
Registers.Is_Row := False;
Done := True;
end Read_And_Execute_Isn;
----------------------
-- Set_Load_Address --
----------------------
procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is
begin
if Addr = Null_Address then
return;
else
C.Load_Slide :=
To_Integer (Addr) - Integer_Address (Get_Load_Address (C.Obj.all));
C.Low := To_Address (To_Integer (C.Low) + C.Load_Slide);
C.High := To_Address (To_Integer (C.High) + C.Load_Slide);
end if;
end Set_Load_Address;
------------------
-- To_File_Name --
------------------
function To_File_Name
(C : in out Dwarf_Context;
Code : uint32) return String
is
Buf : Buffer;
J : uint32;
Dir_Idx : uint32;
pragma Unreferenced (Dir_Idx);
Mod_Time : uint32;
pragma Unreferenced (Mod_Time);
Length : uint32;
pragma Unreferenced (Length);
begin
Seek (C.Lines, C.Prologue.File_Names_Offset);
-- Find the entry
J := 0;
loop
J := J + 1;
Read_C_String (C.Lines, Buf);
if Buf (Buf'First) = 0 then
return "???";
end if;
Dir_Idx := Read_LEB128 (C.Lines);
Mod_Time := Read_LEB128 (C.Lines);
Length := Read_LEB128 (C.Lines);
exit when J = Code;
end loop;
return To_String (Buf);
end To_File_Name;
-------------------------
-- Read_Initial_Length --
-------------------------
procedure Read_Initial_Length
(S : in out Mapped_Stream;
Len : out Offset;
Is64 : out Boolean)
is
Len32 : uint32;
Len64 : uint64;
begin
Len32 := Read (S);
if Len32 < 16#ffff_fff0# then
Is64 := False;
Len := Offset (Len32);
elsif Len32 < 16#ffff_ffff# then
-- Invalid length
raise Constraint_Error;
else
Is64 := True;
Len64 := Read (S);
Len := Offset (Len64);
end if;
end Read_Initial_Length;
-------------------------
-- Read_Section_Offset --
-------------------------
procedure Read_Section_Offset
(S : in out Mapped_Stream;
Len : out Offset;
Is64 : Boolean)
is
begin
if Is64 then
Len := Offset (uint64'(Read (S)));
else
Len := Offset (uint32'(Read (S)));
end if;
end Read_Section_Offset;
--------------------
-- Aranges_Lookup --
--------------------
procedure Aranges_Lookup
(C : in out Dwarf_Context;
Addr : Address;
Info_Offset : out Offset;
Success : out Boolean)
is
begin
Seek (C.Aranges, 0);
while Tell (C.Aranges) < Length (C.Aranges) loop
Read_Aranges_Header (C, Info_Offset, Success);
exit when not Success;
loop
declare
Start : Integer_Address;
Len : Storage_Count;
begin
Read_Aranges_Entry (C, Start, Len);
exit when Start = 0 and Len = 0;
if Addr >= To_Address (Start)
and then Addr < To_Address (Start) + Len
then
Success := True;
return;
end if;
end;
end loop;
end loop;
Success := False;
end Aranges_Lookup;
---------------
-- Skip_Form --
---------------
procedure Skip_Form
(S : in out Mapped_Stream;
Form : uint32;
Is64 : Boolean;
Ptr_Sz : uint8)
is
Skip : Offset;
begin
case Form is
when DW_FORM_addr =>
Skip := Offset (Ptr_Sz);
when DW_FORM_block2 =>
Skip := Offset (uint16'(Read (S)));
when DW_FORM_block4 =>
Skip := Offset (uint32'(Read (S)));
when DW_FORM_data2 | DW_FORM_ref2 =>
Skip := 2;
when DW_FORM_data4 | DW_FORM_ref4 =>
Skip := 4;
when DW_FORM_data8 | DW_FORM_ref8 | DW_FORM_ref_sig8 =>
Skip := 8;
when DW_FORM_string =>
while uint8'(Read (S)) /= 0 loop
null;
end loop;
return;
when DW_FORM_block | DW_FORM_exprloc =>
Skip := Offset (uint32'(Read_LEB128 (S)));
when DW_FORM_block1 | DW_FORM_ref1 =>
Skip := Offset (uint8'(Read (S)));
when DW_FORM_data1 | DW_FORM_flag =>
Skip := 1;
when DW_FORM_sdata =>
declare
Val : constant int32 := Read_LEB128 (S);
pragma Unreferenced (Val);
begin
return;
end;
when DW_FORM_strp | DW_FORM_ref_addr | DW_FORM_sec_offset =>
Skip := (if Is64 then 8 else 4);
when DW_FORM_udata | DW_FORM_ref_udata =>
declare
Val : constant uint32 := Read_LEB128 (S);
pragma Unreferenced (Val);
begin
return;
end;
when DW_FORM_flag_present =>
return;
when DW_FORM_indirect =>
raise Constraint_Error;
when others =>
raise Constraint_Error;
end case;
Seek (S, Tell (S) + Skip);
end Skip_Form;
-----------------
-- Seek_Abbrev --
-----------------
procedure Seek_Abbrev
(C : in out Dwarf_Context;
Abbrev_Offset : Offset;
Abbrev_Num : uint32)
is
Num : uint32;
Abbrev : uint32;
Tag : uint32;
Has_Child : uint8;
pragma Unreferenced (Abbrev, Tag, Has_Child);
begin
Seek (C.Abbrev, Abbrev_Offset);
Num := 1;
loop
exit when Num = Abbrev_Num;
Abbrev := Read_LEB128 (C.Abbrev);
Tag := Read_LEB128 (C.Abbrev);
Has_Child := Read (C.Abbrev);
loop
declare
Name : constant uint32 := Read_LEB128 (C.Abbrev);
Form : constant uint32 := Read_LEB128 (C.Abbrev);
begin
exit when Name = 0 and Form = 0;
end;
end loop;
Num := Num + 1;
end loop;
end Seek_Abbrev;
-----------------------
-- Debug_Info_Lookup --
-----------------------
procedure Debug_Info_Lookup
(C : in out Dwarf_Context;
Info_Offset : Offset;
Line_Offset : out Offset;
Success : out Boolean)
is
Unit_Length : Offset;
Is64 : Boolean;
Version : uint16;
Abbrev_Offset : Offset;
Addr_Sz : uint8;
Abbrev : uint32;
Has_Child : uint8;
pragma Unreferenced (Has_Child);
begin
Success := False;
Seek (C.Info, Info_Offset);
Read_Initial_Length (C.Info, Unit_Length, Is64);
Version := Read (C.Info);
if Version not in 2 .. 4 then
return;
end if;
Read_Section_Offset (C.Info, Abbrev_Offset, Is64);
Addr_Sz := Read (C.Info);
if Addr_Sz /= (Address'Size / SSU) then
return;
end if;
-- Read DIEs
loop
Abbrev := Read_LEB128 (C.Info);
exit when Abbrev /= 0;
end loop;
-- Read abbrev table
Seek_Abbrev (C, Abbrev_Offset, Abbrev);
-- First ULEB128 is the abbrev code
if Read_LEB128 (C.Abbrev) /= Abbrev then
-- Ill formed abbrev table
return;
end if;
-- Then the tag
if Read_LEB128 (C.Abbrev) /= uint32'(DW_TAG_Compile_Unit) then
-- Expect compile unit
return;
end if;
-- Then the has child flag
Has_Child := Read (C.Abbrev);
loop
declare
Name : constant uint32 := Read_LEB128 (C.Abbrev);
Form : constant uint32 := Read_LEB128 (C.Abbrev);
begin
exit when Name = 0 and Form = 0;
if Name = DW_AT_Stmt_List then
case Form is
when DW_FORM_sec_offset =>
Read_Section_Offset (C.Info, Line_Offset, Is64);
when DW_FORM_data4 =>
Line_Offset := Offset (uint32'(Read (C.Info)));
when DW_FORM_data8 =>
Line_Offset := Offset (uint64'(Read (C.Info)));
when others =>
-- Unhandled form
return;
end case;
Success := True;
return;
else
Skip_Form (C.Info, Form, Is64, Addr_Sz);
end if;
end;
end loop;
return;
end Debug_Info_Lookup;
-------------------------
-- Read_Aranges_Header --
-------------------------
procedure Read_Aranges_Header
(C : in out Dwarf_Context;
Info_Offset : out Offset;
Success : out Boolean)
is
Unit_Length : Offset;
Is64 : Boolean;
Version : uint16;
Sz : uint8;
begin
Success := False;
Read_Initial_Length (C.Aranges, Unit_Length, Is64);
Version := Read (C.Aranges);
if Version /= 2 then
return;
end if;
Read_Section_Offset (C.Aranges, Info_Offset, Is64);
-- Read address_size (ubyte)
Sz := Read (C.Aranges);
if Sz /= (Address'Size / SSU) then
return;
end if;
-- Read segment_size (ubyte)
Sz := Read (C.Aranges);
if Sz /= 0 then
return;
end if;
-- Handle alignment on twice the address size
declare
Cur_Off : constant Offset := Tell (C.Aranges);
Align : constant Offset := 2 * Address'Size / SSU;
Space : constant Offset := Cur_Off mod Align;
begin
if Space /= 0 then
Seek (C.Aranges, Cur_Off + Align - Space);
end if;
end;
Success := True;
end Read_Aranges_Header;
------------------------
-- Read_Aranges_Entry --
------------------------
procedure Read_Aranges_Entry
(C : in out Dwarf_Context;
Start : out Integer_Address;
Len : out Storage_Count)
is
begin
-- Read table
if Address'Size = 32 then
declare
S, L : uint32;
begin
S := Read (C.Aranges);
L := Read (C.Aranges);
Start := Integer_Address (S);
Len := Storage_Count (L);
end;
elsif Address'Size = 64 then
declare
S, L : uint64;
begin
S := Read (C.Aranges);
L := Read (C.Aranges);
Start := Integer_Address (S);
Len := Storage_Count (L);
end;
else
raise Constraint_Error;
end if;
end Read_Aranges_Entry;
------------------
-- Enable_Cache --
------------------
procedure Enable_Cache (C : in out Dwarf_Context) is
Cache : Search_Array_Access;
begin
-- Phase 1: count number of symbols. Phase 2: fill the cache.
declare
S : Object_Symbol;
Sz : uint32;
Addr, Prev_Addr : uint32;
Nbr_Symbols : Natural;
begin
for Phase in 1 .. 2 loop
Nbr_Symbols := 0;
S := First_Symbol (C.Obj.all);
Prev_Addr := uint32'Last;
while S /= Null_Symbol loop
-- Discard symbols whose length is 0
Sz := uint32 (Size (S));
-- Try to filter symbols at the same address. This is a best
-- effort as they might not be consecutive.
Addr := uint32 (Value (S) - uint64 (C.Low));
if Sz > 0 and then Addr /= Prev_Addr then
Nbr_Symbols := Nbr_Symbols + 1;
Prev_Addr := Addr;
if Phase = 2 then
C.Cache (Nbr_Symbols) :=
(First => Addr,
Size => Sz,
Sym => uint32 (Off (S)),
Line => 0);
end if;
end if;
S := Next_Symbol (C.Obj.all, S);
end loop;
if Phase = 1 then
-- Allocate the cache
Cache := new Search_Array (1 .. Nbr_Symbols);
C.Cache := Cache;
end if;
end loop;
pragma Assert (Nbr_Symbols = C.Cache'Last);
end;
-- Sort the cache.
Sort_Search_Array (C.Cache.all);
-- Set line offsets
if not C.Has_Debug then
return;
end if;
declare
Info_Offset : Offset;
Line_Offset : Offset;
Success : Boolean;
Ar_Start : Integer_Address;
Ar_Len : Storage_Count;
Start, Len : uint32;
First, Last : Natural;
Mid : Natural;
begin
Seek (C.Aranges, 0);
while Tell (C.Aranges) < Length (C.Aranges) loop
Read_Aranges_Header (C, Info_Offset, Success);
exit when not Success;
Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success);
exit when not Success;
-- Read table
loop
Read_Aranges_Entry (C, Ar_Start, Ar_Len);
exit when Ar_Start = 0 and Ar_Len = 0;
Len := uint32 (Ar_Len);
Start := uint32 (Ar_Start - To_Integer (C.Low));
-- Search START in the array
First := Cache'First;
Last := Cache'Last;
Mid := First; -- In case of array with one element
while First < Last loop
Mid := First + (Last - First) / 2;
if Start < Cache (Mid).First then
Last := Mid - 1;
elsif Start >= Cache (Mid).First + Cache (Mid).Size then
First := Mid + 1;
else
exit;
end if;
end loop;
-- Fill info.
-- There can be overlapping symbols
while Mid > Cache'First
and then Cache (Mid - 1).First <= Start
and then Cache (Mid - 1).First + Cache (Mid - 1).Size > Start
loop
Mid := Mid - 1;
end loop;
while Mid <= Cache'Last loop
if Start < Cache (Mid).First + Cache (Mid).Size
and then Start + Len > Cache (Mid).First
then
-- MID is within the bounds
Cache (Mid).Line := uint32 (Line_Offset);
elsif Start + Len <= Cache (Mid).First then
-- Over
exit;
end if;
Mid := Mid + 1;
end loop;
end loop;
end loop;
end;
end Enable_Cache;
----------------------
-- Symbolic_Address --
----------------------
procedure Symbolic_Address
(C : in out Dwarf_Context;
Addr : Address;
Dir_Name : out Str_Access;
File_Name : out Str_Access;
Subprg_Name : out String_Ptr_Len;
Line_Num : out Natural)
is
procedure Set_Result (Match : Line_Info_Registers);
-- Set results using match
procedure Set_Result (Match : Line_Info_Registers) is
Dir_Idx : uint32;
J : uint32;
Mod_Time : uint32;
pragma Unreferenced (Mod_Time);
Length : uint32;
pragma Unreferenced (Length);
begin
Seek (C.Lines, C.Prologue.File_Names_Offset);
-- Find the entry
J := 0;
loop
J := J + 1;
File_Name := Read_C_String (C.Lines);
if File_Name (File_Name'First) = ASCII.NUL then
-- End of file list, so incorrect entry
return;
end if;
Dir_Idx := Read_LEB128 (C.Lines);
Mod_Time := Read_LEB128 (C.Lines);
Length := Read_LEB128 (C.Lines);
exit when J = Match.File;
end loop;
if Dir_Idx = 0 then
-- No directory
Dir_Name := null;
else
Seek (C.Lines, C.Prologue.Includes_Offset);
J := 0;
loop
J := J + 1;
Dir_Name := Read_C_String (C.Lines);
if Dir_Name (Dir_Name'First) = ASCII.NUL then
-- End of directory list, so ill-formed table
return;
end if;
exit when J = Dir_Idx;
end loop;
end if;
Line_Num := Natural (Match.Line);
end Set_Result;
Addr_Int : constant Integer_Address := To_Integer (Addr);
Previous_Row : Line_Info_Registers;
Info_Offset : Offset;
Line_Offset : Offset;
Success : Boolean;
Done : Boolean;
S : Object_Symbol;
begin
-- Initialize result
Dir_Name := null;
File_Name := null;
Subprg_Name := (null, 0);
Line_Num := 0;
if C.Cache /= null then
-- Look in the cache
declare
Addr_Off : constant uint32 := uint32 (Addr - C.Low);
First, Last, Mid : Natural;
begin
First := C.Cache'First;
Last := C.Cache'Last;
while First <= Last loop
Mid := First + (Last - First) / 2;
if Addr_Off < C.Cache (Mid).First then
Last := Mid - 1;
elsif Addr_Off >= C.Cache (Mid).First + C.Cache (Mid).Size then
First := Mid + 1;
else
exit;
end if;
end loop;
if Addr_Off >= C.Cache (Mid).First
and then Addr_Off < C.Cache (Mid).First + C.Cache (Mid).Size
then
Line_Offset := Offset (C.Cache (Mid).Line);
S := Read_Symbol (C.Obj.all, Offset (C.Cache (Mid).Sym));
Subprg_Name := Object_Reader.Name (C.Obj.all, S);
else
-- Not found
return;
end if;
end;
else
-- Search symbol
S := First_Symbol (C.Obj.all);
while S /= Null_Symbol loop
if Spans (S, uint64 (Addr_Int)) then
Subprg_Name := Object_Reader.Name (C.Obj.all, S);
exit;
end if;
S := Next_Symbol (C.Obj.all, S);
end loop;
-- Search address in aranges table
Aranges_Lookup (C, Addr, Info_Offset, Success);
if not Success then
return;
end if;
-- Search stmt_list in info table
Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success);
if not Success then
return;
end if;
end if;
Seek (C.Lines, Line_Offset);
C.Next_Prologue := 0;
Initialize_State_Machine (C);
Parse_Prologue (C);
-- Advance to the first entry
loop
Read_And_Execute_Isn (C, Done);
if C.Registers.Is_Row then
Previous_Row := C.Registers;
exit;
end if;
exit when Done;
end loop;
-- Read the rest of the entries
while Tell (C.Lines) < C.Next_Prologue loop
Read_And_Execute_Isn (C, Done);
if C.Registers.Is_Row then
if not Previous_Row.End_Sequence
and then Addr_Int >= Integer_Address (Previous_Row.Address)
and then Addr_Int < Integer_Address (C.Registers.Address)
then
Set_Result (Previous_Row);
return;
elsif Addr_Int = Integer_Address (C.Registers.Address) then
Set_Result (C.Registers);
return;
end if;
Previous_Row := C.Registers;
end if;
exit when Done;
end loop;
end Symbolic_Address;
-------------------
-- String_Length --
-------------------
function String_Length (Str : Str_Access) return Natural is
begin
for I in Str'Range loop
if Str (I) = ASCII.NUL then
return I - Str'First;
end if;
end loop;
return Str'Last;
end String_Length;
------------------------
-- 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)
is
use Ada.Characters.Handling;
C : Dwarf_Context := Cin;
Addr : Address;
Dir_Name : Str_Access;
File_Name : Str_Access;
Subprg_Name : String_Ptr_Len;
Line_Num : Natural;
Off : Natural;
begin
if not C.Has_Debug then
Symbol_Found := False;
return;
else
Symbol_Found := True;
end if;
for J in Traceback'Range loop
-- If the buffer is full, no need to do any useless work
exit when Is_Full (Res);
Addr := PC_For (Traceback (J));
Symbolic_Address
(C,
To_Address (To_Integer (Addr) + C.Load_Slide),
Dir_Name,
File_Name,
Subprg_Name,
Line_Num);
if File_Name /= null then
declare
Last : constant Natural := String_Length (File_Name);
Is_Ada : constant Boolean :=
Last > 3
and then
To_Upper (String (File_Name (Last - 3 .. Last - 1))) =
".AD";
-- True if this is an Ada file. This doesn't take into account
-- nonstandard file-naming conventions, but that's OK; this is
-- purely cosmetic. It covers at least .ads, .adb, and .ada.
Line_Image : constant String := Natural'Image (Line_Num);
begin
if Subprg_Name.Len /= 0 then
-- For Ada code, Symbol_Image is in all lower case; we don't
-- have the case from the original source code. But the best
-- guess is Mixed_Case, so convert to that.
if Is_Ada then
declare
Symbol_Image : String :=
Object_Reader.Decoded_Ada_Name
(C.Obj.all,
Subprg_Name);
begin
for K in Symbol_Image'Range loop
if K = Symbol_Image'First
or else not
(Is_Letter (Symbol_Image (K - 1))
or else Is_Digit (Symbol_Image (K - 1)))
then
Symbol_Image (K) := To_Upper (Symbol_Image (K));
end if;
end loop;
Append (Res, Symbol_Image);
end;
else
Off := Strip_Leading_Char (C.Obj.all, Subprg_Name);
Append
(Res,
String (Subprg_Name.Ptr (Off .. Subprg_Name.Len)));
end if;
Append (Res, ' ');
end if;
Append (Res, "at ");
Append (Res, String (File_Name (1 .. Last)));
Append (Res, ':');
Append (Res, Line_Image (2 .. Line_Image'Last));
end;
else
if Suppress_Hex then
Append (Res, "...");
else
Append_Address (Res, Addr);
end if;
if Subprg_Name.Len > 0 then
Off := Strip_Leading_Char (C.Obj.all, Subprg_Name);
Append (Res, ' ');
Append (Res, String (Subprg_Name.Ptr (Off .. Subprg_Name.Len)));
end if;
Append (Res, " at ???");
end if;
Append (Res, ASCII.LF);
end loop;
end Symbolic_Traceback;
end System.Dwarf_Lines;
gcc/ada/s-dwalin.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-objrea.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . O B J E C T _ R E A D E R --
-- --
-- B o d y --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
with Ada.Unchecked_Conversion;
with Interfaces.C;
with System.CRTL;
package body System.Object_Reader is
use Interfaces;
use Interfaces.C;
use System.Mmap;
SSU : constant := System.Storage_Unit;
function To_int32 is new Ada.Unchecked_Conversion (uint32, int32);
function Trim_Trailing_Nuls (Str : String) return String;
-- Return a copy of a string with any trailing NUL characters truncated
procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32);
-- Check that the SIZE bytes at the current offset are still in the stream
-------------------------------------
-- ELF object file format handling --
-------------------------------------
generic
type uword is mod <>;
package ELF_Ops is
-- ELF version codes
ELFCLASS32 : constant := 1; -- 32 bit ELF
ELFCLASS64 : constant := 2; -- 64 bit ELF
-- ELF machine codes
EM_NONE : constant := 0; -- No machine
EM_SPARC : constant := 2; -- SUN SPARC
EM_386 : constant := 3; -- Intel 80386
EM_MIPS : constant := 8; -- MIPS RS3000 Big-Endian
EM_MIPS_RS3_LE : constant := 10; -- MIPS RS3000 Little-Endian
EM_SPARC32PLUS : constant := 18; -- Sun SPARC 32+
EM_PPC : constant := 20; -- PowerPC
EM_PPC64 : constant := 21; -- PowerPC 64-bit
EM_ARM : constant := 40; -- ARM
EM_SPARCV9 : constant := 43; -- SPARC v9 64-bit
EM_IA_64 : constant := 50; -- Intel Merced
EM_X86_64 : constant := 62; -- AMD x86-64 architecture
EN_NIDENT : constant := 16;
type E_Ident_Type is array (0 .. EN_NIDENT - 1) of uint8;
type Header is record
E_Ident : E_Ident_Type; -- Magic number and other info
E_Type : uint16; -- Object file type
E_Machine : uint16; -- Architecture
E_Version : uint32; -- Object file version
E_Entry : uword; -- Entry point virtual address
E_Phoff : uword; -- Program header table file offset
E_Shoff : uword; -- Section header table file offset
E_Flags : uint32; -- Processor-specific flags
E_Ehsize : uint16; -- ELF header size in bytes
E_Phentsize : uint16; -- Program header table entry size
E_Phnum : uint16; -- Program header table entry count
E_Shentsize : uint16; -- Section header table entry size
E_Shnum : uint16; -- Section header table entry count
E_Shstrndx : uint16; -- Section header string table index
end record;
type Section_Header is record
Sh_Name : uint32; -- Section name string table index
Sh_Type : uint32; -- Section type
Sh_Flags : uword; -- Section flags
Sh_Addr : uword; -- Section virtual addr at execution
Sh_Offset : uword; -- Section file offset
Sh_Size : uword; -- Section size in bytes
Sh_Link : uint32; -- Link to another section
Sh_Info : uint32; -- Additional section information
Sh_Addralign : uword; -- Section alignment
Sh_Entsize : uword; -- Entry size if section holds table
end record;
SHF_ALLOC : constant := 2;
type Symtab_Entry32 is record
St_Name : uint32; -- Name (string table index)
St_Value : uint32; -- Value
St_Size : uint32; -- Size in bytes
St_Info : uint8; -- Type and binding attributes
St_Other : uint8; -- Undefined
St_Shndx : uint16; -- Defining section
end record;
type Symtab_Entry64 is record
St_Name : uint32; -- Name (string table index)
St_Info : uint8; -- Type and binding attributes
St_Other : uint8; -- Undefined
St_Shndx : uint16; -- Defining section
St_Value : uint64; -- Value
St_Size : uint64; -- Size in bytes
end record;
function Read_Header (F : in out Mapped_Stream) return Header;
-- Read a header from an ELF format object
function First_Symbol
(Obj : in out ELF_Object_File) return Object_Symbol;
-- Return the first element in the symbol table, or Null_Symbol if the
-- symbol table is empty.
function Read_Symbol
(Obj : in out ELF_Object_File;
Off : Offset) return Object_Symbol;
-- Read a symbol at offset Off
function Name
(Obj : in out ELF_Object_File;
Sym : Object_Symbol) return String_Ptr_Len;
-- Return the name of the symbol
function Name
(Obj : in out ELF_Object_File;
Sec : Object_Section) return String;
-- Return the name of a section
function Get_Section
(Obj : in out ELF_Object_File;
Shnum : uint32) return Object_Section;
-- Fetch a section by index from zero
function Initialize
(F : Mapped_File;
Hdr : Header;
In_Exception : Boolean) return ELF_Object_File;
-- Initialize an object file
end ELF_Ops;
-----------------------------------
-- PECOFF object format handling --
-----------------------------------
package PECOFF_Ops is
-- Constants and data layout are taken from the document "Microsoft
-- Portable Executable and Common Object File Format Specification"
-- Revision 8.1.
Signature_Loc_Offset : constant := 16#3C#;
-- Offset of pointer to the file signature
Size_Of_Standard_Header_Fields : constant := 16#18#;
-- Length in bytes of the standard header record
Function_Symbol_Type : constant := 16#20#;
-- Type field value indicating a symbol refers to a function
Not_Function_Symbol_Type : constant := 16#00#;
-- Type field value indicating a symbol does not refer to a function
type Magic_Array is array (0 .. 3) of uint8;
-- Array of magic numbers from the header
-- Magic numbers for PECOFF variants
VARIANT_PE32 : constant := 16#010B#;
VARIANT_PE32_PLUS : constant := 16#020B#;
-- PECOFF machine codes
IMAGE_FILE_MACHINE_I386 : constant := 16#014C#;
IMAGE_FILE_MACHINE_IA64 : constant := 16#0200#;
IMAGE_FILE_MACHINE_AMD64 : constant := 16#8664#;
-- PECOFF Data layout
type Header is record
Magics : Magic_Array;
Machine : uint16;
NumberOfSections : uint16;
TimeDateStamp : uint32;
PointerToSymbolTable : uint32;
NumberOfSymbols : uint32;
SizeOfOptionalHeader : uint16;
Characteristics : uint16;
Variant : uint16;
end record;
pragma Pack (Header);
type Optional_Header_PE32 is record
Magic : uint16;
MajorLinkerVersion : uint8;
MinorLinkerVersion : uint8;
SizeOfCode : uint32;
SizeOfInitializedData : uint32;
SizeOfUninitializedData : uint32;
AddressOfEntryPoint : uint32;
BaseOfCode : uint32;
BaseOfData : uint32; -- Note: not in PE32+
ImageBase : uint32;
SectionAlignment : uint32;
FileAlignment : uint32;
MajorOperatingSystemVersion : uint16;
MinorOperationSystemVersion : uint16;
MajorImageVersion : uint16;
MinorImageVersion : uint16;
MajorSubsystemVersion : uint16;
MinorSubsystemVersion : uint16;
Win32VersionValue : uint32;
SizeOfImage : uint32;
SizeOfHeaders : uint32;
Checksum : uint32;
Subsystem : uint16;
DllCharacteristics : uint16;
SizeOfStackReserve : uint32;
SizeOfStackCommit : uint32;
SizeOfHeapReserve : uint32;
SizeOfHeapCommit : uint32;
LoaderFlags : uint32;
NumberOfRvaAndSizes : uint32;
end record;
pragma Pack (Optional_Header_PE32);
pragma Assert (Optional_Header_PE32'Size = 96 * SSU);
type Optional_Header_PE64 is record
Magic : uint16;
MajorLinkerVersion : uint8;
MinorLinkerVersion : uint8;
SizeOfCode : uint32;
SizeOfInitializedData : uint32;
SizeOfUninitializedData : uint32;
AddressOfEntryPoint : uint32;
BaseOfCode : uint32;
ImageBase : uint64;
SectionAlignment : uint32;
FileAlignment : uint32;
MajorOperatingSystemVersion : uint16;
MinorOperationSystemVersion : uint16;
MajorImageVersion : uint16;
MinorImageVersion : uint16;
MajorSubsystemVersion : uint16;
MinorSubsystemVersion : uint16;
Win32VersionValue : uint32;
SizeOfImage : uint32;
SizeOfHeaders : uint32;
Checksum : uint32;
Subsystem : uint16;
DllCharacteristics : uint16;
SizeOfStackReserve : uint64;
SizeOfStackCommit : uint64;
SizeOfHeapReserve : uint64;
SizeOfHeapCommit : uint64;
LoaderFlags : uint32;
NumberOfRvaAndSizes : uint32;
end record;
pragma Pack (Optional_Header_PE64);
pragma Assert (Optional_Header_PE64'Size = 112 * SSU);
subtype Name_Str is String (1 .. 8);
type Section_Header is record
Name : Name_Str;
VirtualSize : uint32;
VirtualAddress : uint32;
SizeOfRawData : uint32;
PointerToRawData : uint32;
PointerToRelocations : uint32;
PointerToLinenumbers : uint32;
NumberOfRelocations : uint16;
NumberOfLinenumbers : uint16;
Characteristics : uint32;
end record;
pragma Pack (Section_Header);
IMAGE_SCN_CNT_CODE : constant := 16#0020#;
type Symtab_Entry is record
Name : Name_Str;
Value : uint32;
SectionNumber : int16;
TypeField : uint16;
StorageClass : uint8;
NumberOfAuxSymbols : uint8;
end record;
pragma Pack (Symtab_Entry);
type Auxent_Section is record
Length : uint32;
NumberOfRelocations : uint16;
NumberOfLinenumbers : uint16;
CheckSum : uint32;
Number : uint16;
Selection : uint8;
Unused1 : uint8;
Unused2 : uint8;
Unused3 : uint8;
end record;
for Auxent_Section'Size use 18 * 8;
function Read_Header (F : in out Mapped_Stream) return Header;
-- Read the object file header
function First_Symbol
(Obj : in out PECOFF_Object_File) return Object_Symbol;
-- Return the first element in the symbol table, or Null_Symbol if the
-- symbol table is empty.
function Read_Symbol
(Obj : in out PECOFF_Object_File;
Off : Offset) return Object_Symbol;
-- Read a symbol at offset Off
function Name
(Obj : in out PECOFF_Object_File;
Sym : Object_Symbol) return String_Ptr_Len;
-- Return the name of the symbol
function Name
(Obj : in out PECOFF_Object_File;
Sec : Object_Section) return String;
-- Return the name of a section
function Get_Section
(Obj : in out PECOFF_Object_File;
Index : uint32) return Object_Section;
-- Fetch a section by index from zero
function Initialize
(F : Mapped_File;
Hdr : Header;
In_Exception : Boolean) return PECOFF_Object_File;
-- Initialize an object file
end PECOFF_Ops;
-------------------------------------
-- XCOFF-32 object format handling --
-------------------------------------
package XCOFF32_Ops is
-- XCOFF Data layout
type Header is record
f_magic : uint16;
f_nscns : uint16;
f_timdat : uint32;
f_symptr : uint32;
f_nsyms : uint32;
f_opthdr : uint16;
f_flags : uint16;
end record;
type Auxiliary_Header is record
o_mflag : uint16;
o_vstamp : uint16;
o_tsize : uint32;
o_dsize : uint32;
o_bsize : uint32;
o_entry : uint32;
o_text_start : uint32;
o_data_start : uint32;
o_toc : uint32;
o_snentry : uint16;
o_sntext : uint16;
o_sndata : uint16;
o_sntoc : uint16;
o_snloader : uint16;
o_snbss : uint16;
o_algntext : uint16;
o_algndata : uint16;
o_modtype : uint16;
o_cpuflag : uint8;
o_cputype : uint8;
o_maxstack : uint32;
o_maxdata : uint32;
o_debugger : uint32;
o_flags : uint8;
o_sntdata : uint16;
o_sntbss : uint16;
end record;
pragma Unreferenced (Auxiliary_Header);
-- Not used, but not removed (just in case)
subtype Name_Str is String (1 .. 8);
type Section_Header is record
s_name : Name_Str;
s_paddr : uint32;
s_vaddr : uint32;
s_size : uint32;
s_scnptr : uint32;
s_relptr : uint32;
s_lnnoptr : uint32;
s_nreloc : uint16;
s_nlnno : uint16;
s_flags : uint32;
end record;
pragma Pack (Section_Header);
STYP_TEXT : constant := 16#0020#;
type Symbol_Entry is record
n_name : Name_Str;
n_value : uint32;
n_scnum : uint16;
n_type : uint16;
n_sclass : uint8;
n_numaux : uint8;
end record;
for Symbol_Entry'Size use 18 * 8;
type Aux_Entry is record
x_scnlen : uint32;
x_parmhash : uint32;
x_snhash : uint16;
x_smtyp : uint8;
x_smclass : uint8;
x_stab : uint32;
x_snstab : uint16;
end record;
for Aux_Entry'Size use 18 * 8;
pragma Pack (Aux_Entry);
C_EXT : constant := 2;
C_HIDEXT : constant := 107;
C_WEAKEXT : constant := 111;
XTY_LD : constant := 2;
-- Magic constant should be documented, especially since it's changed???
function Read_Header (F : in out Mapped_Stream) return Header;
-- Read the object file header
function First_Symbol
(Obj : in out XCOFF32_Object_File) return Object_Symbol;
-- Return the first element in the symbol table, or Null_Symbol if the
-- symbol table is empty.
function Read_Symbol
(Obj : in out XCOFF32_Object_File;
Off : Offset) return Object_Symbol;
-- Read a symbol at offset Off
function Name
(Obj : in out XCOFF32_Object_File;
Sym : Object_Symbol) return String_Ptr_Len;
-- Return the name of the symbol
function Name
(Obj : in out XCOFF32_Object_File;
Sec : Object_Section) return String;
-- Return the name of a section
function Initialize
(F : Mapped_File;
Hdr : Header;
In_Exception : Boolean) return XCOFF32_Object_File;
-- Initialize an object file
function Get_Section
(Obj : in out XCOFF32_Object_File;
Index : uint32) return Object_Section;
-- Fetch a section by index from zero
end XCOFF32_Ops;
-------------
-- ELF_Ops --
-------------
package body ELF_Ops is
function Get_String_Table (Obj : in out ELF_Object_File)
return Object_Section;
-- Fetch the section containing the string table
function Get_Symbol_Table (Obj : in out ELF_Object_File)
return Object_Section;
-- Fetch the section containing the symbol table
function Read_Section_Header
(Obj : in out ELF_Object_File;
Shnum : uint32) return Section_Header;
-- Read the header for an ELF format object section indexed from zero
------------------
-- First_Symbol --
------------------
function First_Symbol
(Obj : in out ELF_Object_File) return Object_Symbol
is
begin
if Obj.Symtab_Last = 0 then
return Null_Symbol;
else
return Read_Symbol (Obj, 0);
end if;
end First_Symbol;
-----------------
-- Get_Section --
-----------------
function Get_Section
(Obj : in out ELF_Object_File;
Shnum : uint32) return Object_Section
is
SHdr : constant Section_Header := Read_Section_Header (Obj, Shnum);
begin
return (Shnum,
Offset (SHdr.Sh_Offset),
uint64 (SHdr.Sh_Addr),
uint64 (SHdr.Sh_Size),
(SHdr.Sh_Flags and SHF_ALLOC) /= 0);
end Get_Section;
------------------------
-- Get_String_Table --
------------------------
function Get_String_Table
(Obj : in out ELF_Object_File) return Object_Section
is
begin
-- All cases except MIPS IRIX, string table located in .strtab
if Obj.Arch /= MIPS then
return Get_Section (Obj, ".strtab");
-- On IRIX only .dynstr is available
else
return Get_Section (Obj, ".dynstr");
end if;
end Get_String_Table;
------------------------
-- Get_Symbol_Table --
------------------------
function Get_Symbol_Table
(Obj : in out ELF_Object_File) return Object_Section
is
begin
-- All cases except MIPS IRIX, symbol table located in .symtab
if Obj.Arch /= MIPS then
return Get_Section (Obj, ".symtab");
-- On IRIX, symbol table located somewhere other than .symtab
else
return Get_Section (Obj, ".dynsym");
end if;
end Get_Symbol_Table;
----------------
-- Initialize --
----------------
function Initialize
(F : Mapped_File;
Hdr : Header;
In_Exception : Boolean) return ELF_Object_File
is
Res : ELF_Object_File
(Format => (case uword'Size is
when 64 => ELF64,
when 32 => ELF32,
when others => raise Program_Error));
Sec : Object_Section;
begin
Res.MF := F;
Res.In_Exception := In_Exception;
Res.Num_Sections := uint32 (Hdr.E_Shnum);
case Hdr.E_Machine is
when EM_SPARC
| EM_SPARC32PLUS
=>
Res.Arch := SPARC;
when EM_386 =>
Res.Arch := i386;
when EM_MIPS
| EM_MIPS_RS3_LE
=>
Res.Arch := MIPS;
when EM_PPC =>
Res.Arch := PPC;
when EM_PPC64 =>
Res.Arch := PPC64;
when EM_SPARCV9 =>
Res.Arch := SPARC64;
when EM_IA_64 =>
Res.Arch := IA64;
when EM_X86_64 =>
Res.Arch := x86_64;
when others =>
raise Format_Error with "unrecognized architecture";
end case;
-- Map section table and section string table
Res.Sectab_Stream := Create_Stream
(F, File_Size (Hdr.E_Shoff),
File_Size (Hdr.E_Shnum) * File_Size (Hdr.E_Shentsize));
Sec := Get_Section (Res, uint32 (Hdr.E_Shstrndx));
Res.Secstr_Stream := Create_Stream (Res, Sec);
-- Map symbol and string table
Sec := Get_Symbol_Table (Res);
Res.Symtab_Stream := Create_Stream (Res, Sec);
Res.Symtab_Last := Offset (Sec.Size);
Sec := Get_String_Table (Res);
Res.Symstr_Stream := Create_Stream (Res, Sec);
return Res;
end Initialize;
-----------------
-- Read_Header --
-----------------
function Read_Header (F : in out Mapped_Stream) return Header is
Hdr : Header;
begin
Seek (F, 0);
Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU));
return Hdr;
end Read_Header;
-------------------------
-- Read_Section_Header --
-------------------------
function Read_Section_Header
(Obj : in out ELF_Object_File;
Shnum : uint32) return Section_Header
is
Shdr : Section_Header;
begin
Seek (Obj.Sectab_Stream, Offset (Shnum * Section_Header'Size / SSU));
Read_Raw (Obj.Sectab_Stream, Shdr'Address, Section_Header'Size / SSU);
return Shdr;
end Read_Section_Header;
-----------------
-- Read_Symbol --
-----------------
function Read_Symbol
(Obj : in out ELF_Object_File;
Off : Offset) return Object_Symbol
is
ST_Entry32 : Symtab_Entry32;
ST_Entry64 : Symtab_Entry64;
Res : Object_Symbol;
begin
Seek (Obj.Symtab_Stream, Off);
case uword'Size is
when 32 =>
Read_Raw (Obj.Symtab_Stream, ST_Entry32'Address,
uint32 (ST_Entry32'Size / SSU));
Res := (Off,
Off + ST_Entry32'Size / SSU,
uint64 (ST_Entry32.St_Value),
uint64 (ST_Entry32.St_Size));
when 64 =>
Read_Raw (Obj.Symtab_Stream, ST_Entry64'Address,
uint32 (ST_Entry64'Size / SSU));
Res := (Off,
Off + ST_Entry64'Size / SSU,
ST_Entry64.St_Value,
ST_Entry64.St_Size);
when others =>
raise Program_Error;
end case;
return Res;
end Read_Symbol;
----------
-- Name --
----------
function Name
(Obj : in out ELF_Object_File;
Sec : Object_Section) return String
is
SHdr : Section_Header;
begin
SHdr := Read_Section_Header (Obj, Sec.Num);
return Offset_To_String (Obj.Secstr_Stream, Offset (SHdr.Sh_Name));
end Name;
function Name
(Obj : in out ELF_Object_File;
Sym : Object_Symbol) return String_Ptr_Len
is
ST_Entry32 : Symtab_Entry32;
ST_Entry64 : Symtab_Entry64;
Name_Off : Offset;
begin
-- Test that this symbol is not null
if Sym = Null_Symbol then
return (null, 0);
end if;
-- Read the symbol table entry
Seek (Obj.Symtab_Stream, Sym.Off);
case uword'Size is
when 32 =>
Read_Raw (Obj.Symtab_Stream, ST_Entry32'Address,
uint32 (ST_Entry32'Size / SSU));
Name_Off := Offset (ST_Entry32.St_Name);
when 64 =>
Read_Raw (Obj.Symtab_Stream, ST_Entry64'Address,
uint32 (ST_Entry64'Size / SSU));
Name_Off := Offset (ST_Entry64.St_Name);
when others =>
raise Program_Error;
end case;
-- Fetch the name from the string table
Seek (Obj.Symstr_Stream, Name_Off);
return Read (Obj.Symstr_Stream);
end Name;
end ELF_Ops;
package ELF32_Ops is new ELF_Ops (uint32);
package ELF64_Ops is new ELF_Ops (uint64);
----------------
-- PECOFF_Ops --
----------------
package body PECOFF_Ops is
function Decode_Name
(Obj : in out PECOFF_Object_File;
Raw_Name : String) return String;
-- A section name is an 8 byte field padded on the right with null
-- characters, or a '\' followed by an ASCII decimal string indicating
-- an offset in to the string table. This routine decodes this
function Get_Section_Virtual_Address
(Obj : in out PECOFF_Object_File;
Index : uint32) return uint64;
-- Fetch the address at which a section is loaded
function Read_Section_Header
(Obj : in out PECOFF_Object_File;
Index : uint32) return Section_Header;
-- Read a header from section table
function String_Table
(Obj : in out PECOFF_Object_File;
Index : Offset) return String;
-- Return an entry from the string table
-----------------
-- Decode_Name --
-----------------
function Decode_Name
(Obj : in out PECOFF_Object_File;
Raw_Name : String) return String
is
Name_Or_Ref : constant String := Trim_Trailing_Nuls (Raw_Name);
Off : Offset;
begin
-- We should never find a symbol with a zero length name. If we do it
-- probably means we are not parsing the symbol table correctly. If
-- this happens we raise a fatal error.
if Name_Or_Ref'Length = 0 then
raise Format_Error with
"found zero length symbol in symbol table";
end if;
if Name_Or_Ref (1) /= '/' then
return Name_Or_Ref;
else
Off := Offset'Value (Name_Or_Ref (2 .. Name_Or_Ref'Last));
return String_Table (Obj, Off);
end if;
end Decode_Name;
------------------
-- First_Symbol --
------------------
function First_Symbol
(Obj : in out PECOFF_Object_File) return Object_Symbol is
begin
-- Return Null_Symbol in the case that the symbol table is empty
if Obj.Symtab_Last = 0 then
return Null_Symbol;
end if;
return Read_Symbol (Obj, 0);
end First_Symbol;
-----------------
-- Get_Section --
-----------------
function Get_Section
(Obj : in out PECOFF_Object_File;
Index : uint32) return Object_Section
is
Sec : constant Section_Header := Read_Section_Header (Obj, Index);
begin
-- Use VirtualSize instead of SizeOfRawData. The latter is rounded to
-- the page size, so it may add garbage to the content. On the other
-- side, the former may be larger than the latter in case of 0
-- padding.
return (Index,
Offset (Sec.PointerToRawData),
uint64 (Sec.VirtualAddress) + Obj.ImageBase,
uint64 (Sec.VirtualSize),
(Sec.Characteristics and IMAGE_SCN_CNT_CODE) /= 0);
end Get_Section;
---------------------------------
-- Get_Section_Virtual_Address --
---------------------------------
function Get_Section_Virtual_Address
(Obj : in out PECOFF_Object_File;
Index : uint32) return uint64
is
Sec : Section_Header;
begin
-- Try cache
if Index = Obj.GSVA_Sec then
return Obj.GSVA_Addr;
end if;
Obj.GSVA_Sec := Index;
Sec := Read_Section_Header (Obj, Index);
Obj.GSVA_Addr := Obj.ImageBase + uint64 (Sec.VirtualAddress);
return Obj.GSVA_Addr;
end Get_Section_Virtual_Address;
----------------
-- Initialize --
----------------
function Initialize
(F : Mapped_File;
Hdr : Header;
In_Exception : Boolean) return PECOFF_Object_File
is
Res : PECOFF_Object_File
(Format => (case Hdr.Variant is
when PECOFF_Ops.VARIANT_PE32 => PECOFF,
when PECOFF_Ops.VARIANT_PE32_PLUS => PECOFF_PLUS,
when others => raise Program_Error
with "unrecognized PECOFF variant"));
Symtab_Size : constant Offset :=
Offset (Hdr.NumberOfSymbols) * (Symtab_Entry'Size / SSU);
Strtab_Size : uint32;
Hdr_Offset : Offset;
Opt_Offset : File_Size;
Opt_Stream : Mapped_Stream;
begin
Res.MF := F;
Res.In_Exception := In_Exception;
case Hdr.Machine is
when PECOFF_Ops.IMAGE_FILE_MACHINE_I386 =>
Res.Arch := i386;
when PECOFF_Ops.IMAGE_FILE_MACHINE_IA64 =>
Res.Arch := IA64;
when PECOFF_Ops.IMAGE_FILE_MACHINE_AMD64 =>
Res.Arch := x86_64;
when others =>
raise Format_Error with "unrecognized architecture";
end case;
Res.Num_Sections := uint32 (Hdr.NumberOfSections);
-- Map symbol table and the first following word (which is the length
-- of the string table).
Res.Symtab_Last := Symtab_Size;
Res.Symtab_Stream := Create_Stream
(F,
File_Size (Hdr.PointerToSymbolTable),
File_Size (Symtab_Size + 4));
-- Map string table. The first 4 bytes are the length of the string
-- table and are part of it.
Seek (Res.Symtab_Stream, Symtab_Size);
Strtab_Size := Read (Res.Symtab_Stream);
Res.Symstr_Stream := Create_Stream
(F,
File_Size (Hdr.PointerToSymbolTable) + File_Size (Symtab_Size),
File_Size (Strtab_Size));
-- Map section table
Opt_Stream := Create_Stream (Res.Mf, Signature_Loc_Offset, 4);
Hdr_Offset := Offset (uint32'(Read (Opt_Stream)));
Close (Opt_Stream);
Res.Sectab_Stream := Create_Stream
(F,
File_Size (Hdr_Offset +
Size_Of_Standard_Header_Fields +
Offset (Hdr.SizeOfOptionalHeader)),
File_Size (Res.Num_Sections)
* File_Size (Section_Header'Size / SSU));
-- Read optional header and extract image base
Opt_Offset := File_Size (Hdr_Offset + Size_Of_Standard_Header_Fields);
if Res.Format = PECOFF then
declare
Opt_32 : Optional_Header_PE32;
begin
Opt_Stream := Create_Stream
(Res.Mf, Opt_Offset, Opt_32'Size / SSU);
Read_Raw
(Opt_Stream, Opt_32'Address, uint32 (Opt_32'Size / SSU));
Res.ImageBase := uint64 (Opt_32.ImageBase);
Close (Opt_Stream);
end;
else
declare
Opt_64 : Optional_Header_PE64;
begin
Opt_Stream := Create_Stream
(Res.Mf, Opt_Offset, Opt_64'Size / SSU);
Read_Raw
(Opt_Stream, Opt_64'Address, uint32 (Opt_64'Size / SSU));
Res.ImageBase := Opt_64.ImageBase;
Close (Opt_Stream);
end;
end if;
return Res;
end Initialize;
-----------------
-- Read_Symbol --
-----------------
function Read_Symbol
(Obj : in out PECOFF_Object_File;
Off : Offset) return Object_Symbol
is
ST_Entry : Symtab_Entry;
ST_Last : Symtab_Entry;
Aux_Entry : Auxent_Section;
Sz : constant Offset := ST_Entry'Size / SSU;
Result : Object_Symbol;
Noff : Offset;
Sym_Off : Offset;
begin
-- Seek to the successor of Prev
Noff := Off;
loop
Sym_Off := Noff;
Seek (Obj.Symtab_Stream, Sym_Off);
Read_Raw (Obj.Symtab_Stream, ST_Entry'Address, uint32 (Sz));
-- Skip AUX entries
Noff := Noff + Offset (1 + ST_Entry.NumberOfAuxSymbols) * Sz;
exit when ST_Entry.TypeField = Function_Symbol_Type
and then ST_Entry.SectionNumber > 0;
if Noff >= Obj.Symtab_Last then
return Null_Symbol;
end if;
end loop;
-- Construct the symbol
Result :=
(Off => Sym_Off,
Next => Noff,
Value => uint64 (ST_Entry.Value),
Size => 0);
-- Set the size as accurately as possible
-- The size of a symbol is not directly available so we try scanning
-- to the next function and assuming the code ends there.
loop
-- Read symbol and AUX entries
Sym_Off := Noff;
Seek (Obj.Symtab_Stream, Sym_Off);
Read_Raw (Obj.Symtab_Stream, ST_Last'Address, uint32 (Sz));
for I in 1 .. ST_Last.NumberOfAuxSymbols loop
Read_Raw (Obj.Symtab_Stream, Aux_Entry'Address, uint32 (Sz));
end loop;
Noff := Noff + Offset (1 + ST_Last.NumberOfAuxSymbols) * Sz;
if ST_Last.TypeField = Function_Symbol_Type then
if ST_Last.SectionNumber = ST_Entry.SectionNumber
and then ST_Last.Value >= ST_Entry.Value
then
-- Symbol is a function past ST_Entry
Result.Size := uint64 (ST_Last.Value - ST_Entry.Value);
else
-- Not correlated function
Result.Next := Sym_Off;
end if;
exit;
elsif ST_Last.SectionNumber = ST_Entry.SectionNumber
and then ST_Last.TypeField = Not_Function_Symbol_Type
and then ST_Last.StorageClass = 3
and then ST_Last.NumberOfAuxSymbols = 1
then
-- Symbol is a section
Result.Size := uint64 (ST_Last.Value + Aux_Entry.Length
- ST_Entry.Value);
Result.Next := Noff;
exit;
end if;
exit when Noff >= Obj.Symtab_Last;
end loop;
-- Relocate the address
Result.Value :=
Result.Value + Get_Section_Virtual_Address
(Obj, uint32 (ST_Entry.SectionNumber - 1));
return Result;
end Read_Symbol;
------------------
-- Read_Header --
------------------
function Read_Header (F : in out Mapped_Stream) return Header is
Hdr : Header;
Off : int32;
begin
-- Skip the MSDOS stub, and seek directly to the file offset
Seek (F, Signature_Loc_Offset);
Off := Read (F);
-- Read the COFF file header
Seek (F, Offset (Off));
Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU));
return Hdr;
end Read_Header;
-------------------------
-- Read_Section_Header --
-------------------------
function Read_Section_Header
(Obj : in out PECOFF_Object_File;
Index : uint32) return Section_Header
is
Sec : Section_Header;
begin
Seek (Obj.Sectab_Stream, Offset (Index * Section_Header'Size / SSU));
Read_Raw (Obj.Sectab_Stream, Sec'Address, Section_Header'Size / SSU);
return Sec;
end Read_Section_Header;
----------
-- Name --
----------
function Name
(Obj : in out PECOFF_Object_File;
Sec : Object_Section) return String
is
Shdr : constant Section_Header := Read_Section_Header (Obj, Sec.Num);
begin
return Decode_Name (Obj, Shdr.Name);
end Name;
-------------------
-- String_Table --
-------------------
function String_Table
(Obj : in out PECOFF_Object_File;
Index : Offset) return String is
begin
-- An index of zero is used to represent an empty string, as the
-- first word of the string table is specified to contain the length
-- of the table rather than its contents.
if Index = 0 then
return "";
else
return Offset_To_String (Obj.Symstr_Stream, Index);
end if;
end String_Table;
----------
-- Name --
----------
function Name
(Obj : in out PECOFF_Object_File;
Sym : Object_Symbol) return String_Ptr_Len
is
ST_Entry : Symtab_Entry;
begin
Seek (Obj.Symtab_Stream, Sym.Off);
Read_Raw (Obj.Symtab_Stream, ST_Entry'Address, ST_Entry'Size / SSU);
declare
-- Symbol table entries are packed and Table_Entry.Name may not be
-- sufficiently aligned to interpret as a 32 bit word, so it is
-- copied to a temporary
Aligned_Name : Name_Str := ST_Entry.Name;
for Aligned_Name'Alignment use 4;
First_Word : uint32;
pragma Import (Ada, First_Word);
-- Suppress initialization in Normalized_Scalars mode
for First_Word'Address use Aligned_Name (1)'Address;
Second_Word : uint32;
pragma Import (Ada, Second_Word);
-- Suppress initialization in Normalized_Scalars mode
for Second_Word'Address use Aligned_Name (5)'Address;
begin
if First_Word = 0 then
-- Second word is an offset in the symbol table
if Second_Word = 0 then
return (null, 0);
else
Seek (Obj.Symstr_Stream, int64 (Second_Word));
return Read (Obj.Symstr_Stream);
end if;
else
-- Inlined symbol name
Seek (Obj.Symtab_Stream, Sym.Off);
return To_String_Ptr_Len (Read (Obj.Symtab_Stream), 8);
end if;
end;
end Name;
end PECOFF_Ops;
-----------------
-- XCOFF32_Ops --
-----------------
package body XCOFF32_Ops is
function Read_Section_Header
(Obj : in out XCOFF32_Object_File;
Index : uint32) return Section_Header;
-- Read a header from section table
-----------------
-- Read_Symbol --
-----------------
function Read_Symbol
(Obj : in out XCOFF32_Object_File;
Off : Offset) return Object_Symbol
is
Sym : Symbol_Entry;
Sz : constant Offset := Symbol_Entry'Size / SSU;
Aux : Aux_Entry;
Result : Object_Symbol;
Noff : Offset;
Sym_Off : Offset;
procedure Read_LD_Symbol;
-- Read the next LD symbol
--------------------
-- Read_LD_Symbol --
--------------------
procedure Read_LD_Symbol is
begin
loop
Sym_Off := Noff;
Read_Raw (Obj.Symtab_Stream, Sym'Address, uint32 (Sz));
Noff := Noff + Offset (1 + Sym.n_numaux) * Sz;
for J in 1 .. Sym.n_numaux loop
Read_Raw (Obj.Symtab_Stream, Aux'Address, uint32 (Sz));
end loop;
exit when Noff >= Obj.Symtab_Last;
exit when Sym.n_numaux = 1
and then Sym.n_scnum /= 0
and then (Sym.n_sclass = C_EXT
or else Sym.n_sclass = C_HIDEXT
or else Sym.n_sclass = C_WEAKEXT)
and then Aux.x_smtyp = XTY_LD;
end loop;
end Read_LD_Symbol;
-- Start of processing for Read_Symbol
begin
Seek (Obj.Symtab_Stream, Off);
Noff := Off;
Read_LD_Symbol;
if Noff >= Obj.Symtab_Last then
return Null_Symbol;
end if;
-- Construct the symbol
Result := (Off => Sym_Off,
Next => Noff,
Value => uint64 (Sym.n_value),
Size => 0);
-- Look for the next symbol to compute the size
Read_LD_Symbol;
if Noff >= Obj.Symtab_Last then
return Null_Symbol;
end if;
Result.Size := uint64 (Sym.n_value) - Result.Value;
Result.Next := Sym_Off;
return Result;
end Read_Symbol;
------------------
-- First_Symbol --
------------------
function First_Symbol
(Obj : in out XCOFF32_Object_File) return Object_Symbol
is
begin
-- Return Null_Symbol in the case that the symbol table is empty
if Obj.Symtab_Last = 0 then
return Null_Symbol;
end if;
return Read_Symbol (Obj, 0);
end First_Symbol;
----------------
-- Initialize --
----------------
function Initialize
(F : Mapped_File;
Hdr : Header;
In_Exception : Boolean) return XCOFF32_Object_File
is
Res : XCOFF32_Object_File (Format => XCOFF32);
Strtab_Sz : uint32;
begin
Res.Mf := F;
Res.In_Exception := In_Exception;
Res.Arch := PPC;
-- Map sections table
Res.Num_Sections := uint32 (Hdr.f_nscns);
Res.Sectab_Stream := Create_Stream
(F,
File_Size (Header'Size / SSU) + File_Size (Hdr.f_opthdr),
File_Size (Hdr.f_nscns) * (Section_Header'Size / SSU));
-- Map symbols table
Res.Symtab_Last := Offset (Hdr.f_nscns) * (Symbol_Entry'Size / SSU);
Res.Symtab_Stream := Create_Stream
(F,
File_Size (Hdr.f_symptr),
File_Size (Res.Symtab_Last) + 4);
-- Map string table
Seek (Res.Symtab_Stream, Res.Symtab_Last);
Strtab_Sz := Read (Res.Symtab_Stream);
Res.Symstr_Stream := Create_Stream
(F,
File_Size (Res.Symtab_Last) + 4,
File_Size (Strtab_Sz) - 4);
return Res;
end Initialize;
-----------------
-- Get_Section --
-----------------
function Get_Section
(Obj : in out XCOFF32_Object_File;
Index : uint32) return Object_Section
is
Sec : constant Section_Header := Read_Section_Header (Obj, Index);
begin
return (Index, Offset (Sec.s_scnptr),
uint64 (Sec.s_vaddr),
uint64 (Sec.s_size),
(Sec.s_flags and STYP_TEXT) /= 0);
end Get_Section;
-----------------
-- Read_Header --
-----------------
function Read_Header (F : in out Mapped_Stream) return Header is
Hdr : Header;
begin
Seek (F, 0);
Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU));
return Hdr;
end Read_Header;
-------------------------
-- Read_Section_Header --
-------------------------
function Read_Section_Header
(Obj : in out XCOFF32_Object_File;
Index : uint32) return Section_Header
is
Sec : Section_Header;
begin
-- Seek to the end of the object header
Seek (Obj.Sectab_Stream, Offset (Index * Section_Header'Size / SSU));
-- Read the section
Read_Raw (Obj.Sectab_Stream, Sec'Address, Section_Header'Size / SSU);
return Sec;
end Read_Section_Header;
----------
-- Name --
----------
function Name
(Obj : in out XCOFF32_Object_File;
Sec : Object_Section) return String
is
Hdr : Section_Header;
begin
Hdr := Read_Section_Header (Obj, Sec.Num);
return Trim_Trailing_Nuls (Hdr.s_name);
end Name;
----------
-- Name --
----------
function Name
(Obj : in out XCOFF32_Object_File;
Sym : Object_Symbol) return String_Ptr_Len
is
Symbol : Symbol_Entry;
begin
Seek (Obj.Symtab_Stream, Sym.Off);
Read_Raw (Obj.Symtab_Stream, Symbol'Address, Symbol'Size / SSU);
declare
First_Word : uint32;
pragma Import (Ada, First_Word);
-- Suppress initialization in Normalized_Scalars mode
for First_Word'Address use Symbol.n_name (1)'Address;
Second_Word : uint32;
pragma Import (Ada, Second_Word);
-- Suppress initialization in Normalized_Scalars mode
for Second_Word'Address use Symbol.n_name (5)'Address;
begin
if First_Word = 0 then
if Second_Word = 0 then
return (null, 0);
else
Seek (Obj.Symstr_Stream, int64 (Second_Word));
return Read (Obj.Symstr_Stream);
end if;
else
Seek (Obj.Symtab_Stream, Sym.Off);
return To_String_Ptr_Len (Read (Obj.Symstr_Stream), 8);
end if;
end;
end Name;
end XCOFF32_Ops;
----------
-- Arch --
----------
function Arch (Obj : Object_File) return Object_Arch is
begin
return Obj.Arch;
end Arch;
function Create_Stream
(Mf : Mapped_File;
File_Offset : File_Size;
File_Length : File_Size)
return Mapped_Stream
is
Region : Mapped_Region;
begin
Read (Mf, Region, File_Offset, File_Length, False);
return (Region, 0, Offset (File_Length));
end Create_Stream;
function Create_Stream
(Obj : Object_File;
Sec : Object_Section) return Mapped_Stream is
begin
return Create_Stream (Obj.Mf, File_Size (Sec.Off), File_Size (Sec.Size));
end Create_Stream;
procedure Tell (Obj : in out Mapped_Stream; Off : out Offset) is
begin
Off := Obj.Off;
end Tell;
function Tell (Obj : Mapped_Stream) return Offset is
begin
return Obj.Off;
end Tell;
function Length (Obj : Mapped_Stream) return Offset is
begin
return Obj.Len;
end Length;
-----------
-- Close --
-----------
procedure Close (S : in out Mapped_Stream) is
begin
Free (S.Region);
end Close;
procedure Close (Obj : in out Object_File) is
begin
Close (Obj.Symtab_Stream);
Close (Obj.Symstr_Stream);
Close (Obj.Sectab_Stream);
case Obj.Format is
when ELF =>
Close (Obj.Secstr_Stream);
when Any_PECOFF =>
null;
when XCOFF32 =>
null;
end case;
Close (Obj.Mf);
end Close;
------------------------
-- Strip_Leading_Char --
------------------------
function Strip_Leading_Char
(Obj : in out Object_File;
Sym : String_Ptr_Len) return Positive is
begin
if (Obj.Format = PECOFF and then Sym.Ptr (1) = '_')
or else
(Obj.Format = XCOFF32 and then Sym.Ptr (1) = '.')
then
return 2;
else
return 1;
end if;
end Strip_Leading_Char;
----------------------
-- Decoded_Ada_Name --
----------------------
function Decoded_Ada_Name
(Obj : in out Object_File;
Sym : String_Ptr_Len) return String
is
procedure gnat_decode
(Coded_Name_Addr : Address;
Ada_Name_Addr : Address;
Verbose : int);
pragma Import (C, gnat_decode, "__gnat_decode");
subtype size_t is Interfaces.C.size_t;
Sym_Name : constant String :=
String (Sym.Ptr (1 .. Sym.Len)) & ASCII.NUL;
Decoded : char_array (0 .. size_t (Sym.Len) * 2 + 60);
Off : Natural;
begin
-- In the PECOFF case most but not all symbol table entries have an
-- extra leading underscore. In this case we trim it.
Off := Strip_Leading_Char (Obj, Sym);
gnat_decode (Sym_Name (Off)'Address, Decoded'Address, 0);
return To_Ada (Decoded);
end Decoded_Ada_Name;
------------------
-- First_Symbol --
------------------
function First_Symbol (Obj : in out Object_File) return Object_Symbol is
begin
case Obj.Format is
when ELF32 => return ELF32_Ops.First_Symbol (Obj);
when ELF64 => return ELF64_Ops.First_Symbol (Obj);
when Any_PECOFF => return PECOFF_Ops.First_Symbol (Obj);
when XCOFF32 => return XCOFF32_Ops.First_Symbol (Obj);
end case;
end First_Symbol;
------------
-- Format --
------------
function Format (Obj : Object_File) return Object_Format is
begin
return Obj.Format;
end Format;
----------------------
-- Get_Load_Address --
----------------------
function Get_Load_Address (Obj : Object_File) return uint64 is
begin
raise Format_Error with "Get_Load_Address not implemented";
return 0;
end Get_Load_Address;
-----------------
-- Get_Section --
-----------------
function Get_Section
(Obj : in out Object_File;
Shnum : uint32) return Object_Section is
begin
case Obj.Format is
when ELF32 => return ELF32_Ops.Get_Section (Obj, Shnum);
when ELF64 => return ELF64_Ops.Get_Section (Obj, Shnum);
when Any_PECOFF => return PECOFF_Ops.Get_Section (Obj, Shnum);
when XCOFF32 => return XCOFF32_Ops.Get_Section (Obj, Shnum);
end case;
end Get_Section;
function Get_Section
(Obj : in out Object_File;
Sec_Name : String) return Object_Section
is
Sec : Object_Section;
begin
for J in 0 .. Obj.Num_Sections - 1 loop
Sec := Get_Section (Obj, J);
if Name (Obj, Sec) = Sec_Name then
return Sec;
end if;
end loop;
if Obj.In_Exception then
return Null_Section;
else
raise Format_Error with "could not find section in object file";
end if;
end Get_Section;
-----------------------
-- Get_Memory_Bounds --
-----------------------
procedure Get_Memory_Bounds
(Obj : in out Object_File;
Low, High : out uint64) is
Sec : Object_Section;
begin
-- First set as an empty range
Low := uint64'Last;
High := uint64'First;
for Idx in 1 .. Num_Sections (Obj) loop
Sec := Get_Section (Obj, Idx - 1);
if Sec.Flag_Alloc then
if Sec.Addr < Low then
Low := Sec.Addr;
end if;
if Sec.Addr + Sec.Size > High then
High := Sec.Addr + Sec.Size;
end if;
end if;
end loop;
end Get_Memory_Bounds;
----------
-- Name --
----------
function Name
(Obj : in out Object_File;
Sec : Object_Section) return String is
begin
case Obj.Format is
when ELF32 => return ELF32_Ops.Name (Obj, Sec);
when ELF64 => return ELF64_Ops.Name (Obj, Sec);
when Any_PECOFF => return PECOFF_Ops.Name (Obj, Sec);
when XCOFF32 => return XCOFF32_Ops.Name (Obj, Sec);
end case;
end Name;
function Name
(Obj : in out Object_File;
Sym : Object_Symbol) return String_Ptr_Len is
begin
case Obj.Format is
when ELF32 => return ELF32_Ops.Name (Obj, Sym);
when ELF64 => return ELF64_Ops.Name (Obj, Sym);
when Any_PECOFF => return PECOFF_Ops.Name (Obj, Sym);
when XCOFF32 => return XCOFF32_Ops.Name (Obj, Sym);
end case;
end Name;
-----------------
-- Next_Symbol --
-----------------
function Next_Symbol
(Obj : in out Object_File;
Prev : Object_Symbol) return Object_Symbol is
begin
-- Test whether we've reached the end of the symbol table
if Prev.Next >= Obj.Symtab_Last then
return Null_Symbol;
end if;
return Read_Symbol (Obj, Prev.Next);
end Next_Symbol;
---------
-- Num --
---------
function Num (Sec : Object_Section) return uint32 is
begin
return Sec.Num;
end Num;
------------------
-- Num_Sections --
------------------
function Num_Sections (Obj : Object_File) return uint32 is
begin
return Obj.Num_Sections;
end Num_Sections;
---------
-- Off --
---------
function Off (Sec : Object_Section) return Offset is
begin
return Sec.Off;
end Off;
function Off (Sym : Object_Symbol) return Offset is
begin
return Sym.Off;
end Off;
----------------------
-- Offset_To_String --
----------------------
function Offset_To_String
(S : in out Mapped_Stream;
Off : Offset) return String
is
Buf : Buffer;
begin
Seek (S, Off);
Read_C_String (S, Buf);
return To_String (Buf);
end Offset_To_String;
----------
-- Open --
----------
function Open
(File_Name : String;
In_Exception : Boolean := False) return Object_File_Access
is
F : Mapped_File;
Hdr_Stream : Mapped_Stream;
begin
-- Open the file
F := Open_Read_No_Exception (File_Name);
if F = Invalid_Mapped_File then
if In_Exception then
return null;
else
raise IO_Error with "could not open object file";
end if;
end if;
Hdr_Stream := Create_Stream (F, 0, 4096);
declare
Hdr : constant ELF32_Ops.Header := ELF32_Ops.Read_Header (Hdr_Stream);
begin
-- Look for the magic numbers for the ELF case
if Hdr.E_Ident (0) = 16#7F# and then
Hdr.E_Ident (1) = Character'Pos ('E') and then
Hdr.E_Ident (2) = Character'Pos ('L') and then
Hdr.E_Ident (3) = Character'Pos ('F') and then
Hdr.E_Ident (4) = ELF32_Ops.ELFCLASS32
then
Close (Hdr_Stream);
return new Object_File'
(ELF32_Ops.Initialize (F, Hdr, In_Exception));
end if;
end;
declare
Hdr : constant ELF64_Ops.Header :=
ELF64_Ops.Read_Header (Hdr_Stream);
begin
-- Look for the magic numbers for the ELF case
if Hdr.E_Ident (0) = 16#7F# and then
Hdr.E_Ident (1) = Character'Pos ('E') and then
Hdr.E_Ident (2) = Character'Pos ('L') and then
Hdr.E_Ident (3) = Character'Pos ('F') and then
Hdr.E_Ident (4) = ELF32_Ops.ELFCLASS64
then
Close (Hdr_Stream);
return new Object_File'
(ELF64_Ops.Initialize (F, Hdr, In_Exception));
end if;
end;
declare
Hdr : constant PECOFF_Ops.Header :=
PECOFF_Ops.Read_Header (Hdr_Stream);
begin
-- Test the magic numbers
if Hdr.Magics (0) = Character'Pos ('P') and then
Hdr.Magics (1) = Character'Pos ('E') and then
Hdr.Magics (2) = 0 and then
Hdr.Magics (3) = 0
then
Close (Hdr_Stream);
return new Object_File'
(PECOFF_Ops.Initialize (F, Hdr, In_Exception));
end if;
exception
-- If this is not a PECOFF file then we've done a seek and read to a
-- random address, possibly raising IO_Error
when IO_Error =>
null;
end;
declare
Hdr : constant XCOFF32_Ops.Header :=
XCOFF32_Ops.Read_Header (Hdr_Stream);
begin
-- Test the magic numbers
if Hdr.f_magic = 8#0737# then
Close (Hdr_Stream);
return new Object_File'
(XCOFF32_Ops.Initialize (F, Hdr, In_Exception));
end if;
end;
Close (Hdr_Stream);
if In_Exception then
return null;
else
raise Format_Error with "unrecognized object format";
end if;
end Open;
----------
-- Read --
----------
function Read (S : in out Mapped_Stream) return Mmap.Str_Access
is
function To_Str_Access is
new Ada.Unchecked_Conversion (Address, Str_Access);
begin
return To_Str_Access (Data (S.Region) (Natural (S.Off + 1))'Address);
end Read;
function Read (S : in out Mapped_Stream) return String_Ptr_Len is
begin
return To_String_Ptr_Len (Read (S));
end Read;
procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32) is
begin
if S.Off + Offset (Size) > Offset (Last (S.Region)) then
raise IO_Error with "could not read from object file";
end if;
end Check_Read_Offset;
procedure Read_Raw
(S : in out Mapped_Stream;
Addr : Address;
Size : uint32)
is
function To_Str_Access is
new Ada.Unchecked_Conversion (Address, Str_Access);
Sz : constant Offset := Offset (Size);
begin
-- Check size
pragma Debug (Check_Read_Offset (S, Size));
-- Copy data
To_Str_Access (Addr) (1 .. Positive (Sz)) :=
Data (S.Region) (Positive (S.Off + 1) .. Positive (S.Off + Sz));
-- Update offset
S.Off := S.Off + Sz;
end Read_Raw;
function Read (S : in out Mapped_Stream) return uint8 is
Data : uint8;
begin
Read_Raw (S, Data'Address, Data'Size / SSU);
return Data;
end Read;
function Read (S : in out Mapped_Stream) return uint16 is
Data : uint16;
begin
Read_Raw (S, Data'Address, Data'Size / SSU);
return Data;
end Read;
function Read (S : in out Mapped_Stream) return uint32 is
Data : uint32;
begin
Read_Raw (S, Data'Address, Data'Size / SSU);
return Data;
end Read;
function Read (S : in out Mapped_Stream) return uint64 is
Data : uint64;
begin
Read_Raw (S, Data'Address, Data'Size / SSU);
return Data;
end Read;
function Read (S : in out Mapped_Stream) return int8 is
Data : int8;
begin
Read_Raw (S, Data'Address, Data'Size / SSU);
return Data;
end Read;
function Read (S : in out Mapped_Stream) return int16 is
Data : int16;
begin
Read_Raw (S, Data'Address, Data'Size / SSU);
return Data;
end Read;
function Read (S : in out Mapped_Stream) return int32 is
Data : int32;
begin
Read_Raw (S, Data'Address, Data'Size / SSU);
return Data;
end Read;
function Read (S : in out Mapped_Stream) return int64 is
Data : int64;
begin
Read_Raw (S, Data'Address, Data'Size / SSU);
return Data;
end Read;
------------------
-- Read_Address --
------------------
function Read_Address
(Obj : Object_File; S : in out Mapped_Stream) return uint64 is
Address_32 : uint32;
Address_64 : uint64;
begin
case Obj.Arch is
when i386
| MIPS
| PPC
| SPARC
=>
Address_32 := Read (S);
return uint64 (Address_32);
when IA64
| PPC64
| SPARC64
| x86_64
=>
Address_64 := Read (S);
return Address_64;
when Unknown =>
raise Format_Error with "unrecognized machine architecture";
end case;
end Read_Address;
-------------------
-- Read_C_String --
-------------------
procedure Read_C_String (S : in out Mapped_Stream; B : out Buffer) is
J : Integer := 0;
begin
loop
-- Handle overflow case
if J = B'Last then
B (J) := 0;
exit;
end if;
B (J) := Read (S);
exit when B (J) = 0;
J := J + 1;
end loop;
end Read_C_String;
-------------------
-- Read_C_String --
-------------------
function Read_C_String (S : in out Mapped_Stream) return Str_Access is
Res : constant Str_Access := Read (S);
begin
for J in Res'Range loop
if S.Off + Offset (J - 1) > Offset (Last (S.Region)) then
raise IO_Error with "could not read from object file";
end if;
if Res (J) = ASCII.NUL then
S.Off := S.Off + Offset (J);
return Res;
end if;
end loop;
-- Overflow case
raise Constraint_Error;
end Read_C_String;
-----------------
-- Read_LEB128 --
-----------------
function Read_LEB128 (S : in out Mapped_Stream) return uint32 is
B : uint8;
Shift : Integer := 0;
Res : uint32 := 0;
begin
loop
B := Read (S);
Res := Res or Shift_Left (uint32 (B and 16#7f#), Shift);
exit when (B and 16#80#) = 0;
Shift := Shift + 7;
end loop;
return Res;
end Read_LEB128;
function Read_LEB128 (S : in out Mapped_Stream) return int32 is
B : uint8;
Shift : Integer := 0;
Res : uint32 := 0;
begin
loop
B := Read (S);
Res := Res or Shift_Left (uint32 (B and 16#7f#), Shift);
Shift := Shift + 7;
exit when (B and 16#80#) = 0;
end loop;
if Shift < 32 and then (Res and Shift_Left (1, Shift - 1)) /= 0 then
Res := Res or Shift_Left (-1, Shift);
end if;
return To_int32 (Res);
end Read_LEB128;
-----------------
-- Read_Symbol --
-----------------
function Read_Symbol
(Obj : in out Object_File;
Off : Offset) return Object_Symbol is
begin
case Obj.Format is
when ELF32 => return ELF32_Ops.Read_Symbol (Obj, Off);
when ELF64 => return ELF64_Ops.Read_Symbol (Obj, Off);
when Any_PECOFF => return PECOFF_Ops.Read_Symbol (Obj, Off);
when XCOFF32 => return XCOFF32_Ops.Read_Symbol (Obj, Off);
end case;
end Read_Symbol;
----------
-- Seek --
----------
procedure Seek (S : in out Mapped_Stream; Off : Offset) is
begin
if Off < 0 or else Off > Offset (Last (S.Region)) then
raise IO_Error with "could not seek to offset in object file";
end if;
S.Off := Off;
end Seek;
----------
-- Size --
----------
function Size (Sec : Object_Section) return uint64 is
begin
return Sec.Size;
end Size;
function Size (Sym : Object_Symbol) return uint64 is
begin
return Sym.Size;
end Size;
------------
-- Strlen --
------------
function Strlen (Buf : Buffer) return int32 is
begin
return int32 (CRTL.strlen (Buf'Address));
end Strlen;
-----------
-- Spans --
-----------
function Spans (Sym : Object_Symbol; Addr : uint64) return Boolean is
begin
return Addr >= Sym.Value and then Addr < Sym.Value + Sym.Size;
end Spans;
---------------
-- To_String --
---------------
function To_String (Buf : Buffer) return String is
Result : String (1 .. Integer (CRTL.strlen (Buf'Address)));
for Result'Address use Buf'Address;
pragma Import (Ada, Result);
begin
return Result;
end To_String;
-----------------------
-- To_String_Ptr_Len --
-----------------------
function To_String_Ptr_Len
(Ptr : Mmap.Str_Access;
Max_Len : Natural := Natural'Last) return String_Ptr_Len is
begin
for I in 1 .. Max_Len loop
if Ptr (I) = ASCII.NUL then
return (Ptr, I - 1);
end if;
end loop;
return (Ptr, Max_Len);
end To_String_Ptr_Len;
------------------------
-- Trim_Trailing_Nuls --
------------------------
function Trim_Trailing_Nuls (Str : String) return String is
begin
for J in Str'Range loop
if Str (J) = ASCII.NUL then
return Str (Str'First .. J - 1);
end if;
end loop;
return Str;
end Trim_Trailing_Nuls;
-----------
-- Value --
-----------
function Value (Sym : Object_Symbol) return uint64 is
begin
return Sym.Value;
end Value;
end System.Object_Reader;
gcc/ada/s-objrea.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-trasym-dwarf.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-tsmona-linux.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-tsmona-mingw.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment