From: Arnaud Charlet Date: Fri, 8 Sep 2017 11:00:52 +0000 (+0200) Subject: s-dwalin.ads, [...]: New. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=a2529c0aa7712b562d28fde46257a36183b60eab;p=gcc.git s-dwalin.ads, [...]: New. 2017-09-08 Arnaud Charlet * 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 --- diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 482259ee3cd..9ad7783e43b 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -429,6 +429,25 @@ X86_64_TARGET_PAIRS = \ a-numaux.adb. -- +-- -- +-- 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; diff --git a/gcc/ada/s-dwalin.ads b/gcc/ada/s-dwalin.ads new file mode 100644 index 00000000000..3608fef3ade --- /dev/null +++ b/gcc/ada/s-dwalin.ads @@ -0,0 +1,191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . D W A R F _ L I N E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-objrea.adb b/gcc/ada/s-objrea.adb new file mode 100644 index 00000000000..451abcd3d7b --- /dev/null +++ b/gcc/ada/s-objrea.adb @@ -0,0 +1,2246 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-objrea.ads b/gcc/ada/s-objrea.ads new file mode 100644 index 00000000000..1d485369b79 --- /dev/null +++ b/gcc/ada/s-objrea.ads @@ -0,0 +1,451 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . O B J E C T _ R E A D E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-trasym-dwarf.adb b/gcc/ada/s-trasym-dwarf.adb new file mode 100644 index 00000000000..9655722b923 --- /dev/null +++ b/gcc/ada/s-trasym-dwarf.adb @@ -0,0 +1,689 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-tsmona-linux.adb b/gcc/ada/s-tsmona-linux.adb new file mode 100644 index 00000000000..8c1f8b4ada8 --- /dev/null +++ b/gcc/ada/s-tsmona-linux.adb @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-tsmona-mingw.adb b/gcc/ada/s-tsmona-mingw.adb new file mode 100644 index 00000000000..46c35cd791a --- /dev/null +++ b/gcc/ada/s-tsmona-mingw.adb @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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;