Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/libgnat/s-dwalin.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/libgnat/s-dwalin.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,1627 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . D W A R F _ L I N E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we can get +-- elaboration circularities when polling is turned on + +with Ada.Characters.Handling; +with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; +with Ada.Unchecked_Deallocation; +with Ada.Containers.Generic_Array_Sort; + +with Interfaces; use Interfaces; + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; +with System.Address_Image; +with System.IO; use System.IO; +with System.Object_Reader; use System.Object_Reader; +with System.Traceback_Entries; use System.Traceback_Entries; +with System.Mmap; use System.Mmap; +with System.Bounded_Strings; use System.Bounded_Strings; + +package body System.Dwarf_Lines is + + SSU : constant := System.Storage_Unit; + + function String_Length (Str : Str_Access) return Natural; + -- Return the length of the C string Str + + --------------------------------- + -- DWARF Parser Implementation -- + --------------------------------- + + procedure Read_Initial_Length + (S : in out Mapped_Stream; + Len : out Offset; + Is64 : out Boolean); + -- Read initial length as specified by Dwarf-4 7.2.2 + + procedure Read_Section_Offset + (S : in out Mapped_Stream; + Len : out Offset; + Is64 : Boolean); + -- Read a section offset, as specified by Dwarf-4 7.4 + + procedure Read_Aranges_Entry + (C : in out Dwarf_Context; + Start : out Integer_Address; + Len : out Storage_Count); + -- Read a single .debug_aranges pair + + procedure Read_Aranges_Header + (C : in out Dwarf_Context; + Info_Offset : out Offset; + Success : out Boolean); + -- Read .debug_aranges header + + procedure Aranges_Lookup + (C : in out Dwarf_Context; + Addr : Address; + Info_Offset : out Offset; + Success : out Boolean); + -- Search for Addr in .debug_aranges and return offset Info_Offset in + -- .debug_info. + + procedure Skip_Form + (S : in out Mapped_Stream; + Form : uint32; + Is64 : Boolean; + Ptr_Sz : uint8); + -- Advance offset in S for Form. + + procedure Seek_Abbrev + (C : in out Dwarf_Context; + Abbrev_Offset : Offset; + Abbrev_Num : uint32); + -- Seek to abbrev Abbrev_Num (starting from Abbrev_Offset) + + procedure Debug_Info_Lookup + (C : in out Dwarf_Context; + Info_Offset : Offset; + Line_Offset : out Offset; + Success : out Boolean); + -- Search for stmt_list tag in Info_Offset and set Line_Offset to the + -- offset in .debug_lines. Only look at the first DIE, which should be + -- a compilation unit. + + procedure Initialize_Pass (C : in out Dwarf_Context); + -- Seek to the first byte of the first prologue and prepare to make a pass + -- over the line number entries. + + procedure Initialize_State_Machine (C : in out Dwarf_Context); + -- Set all state machine registers to their specified initial values + + procedure Parse_Prologue (C : in out Dwarf_Context); + -- Decode a DWARF statement program prologue + + procedure Read_And_Execute_Isn + (C : in out Dwarf_Context; + Done : out Boolean); + -- Read an execute a statement program instruction + + function To_File_Name + (C : in out Dwarf_Context; + Code : uint32) return String; + -- Extract a file name from the prologue + + type Callback is access procedure (C : in out Dwarf_Context); + procedure For_Each_Row (C : in out Dwarf_Context; F : Callback); + -- Traverse each .debug_line entry with a callback + + procedure Dump_Row (C : in out Dwarf_Context); + -- Dump a single row + + function "<" (Left, Right : Search_Entry) return Boolean; + -- For sorting Search_Entry + + procedure Sort_Search_Array is new Ada.Containers.Generic_Array_Sort + (Index_Type => Natural, + Element_Type => Search_Entry, + Array_Type => Search_Array); + + procedure Symbolic_Address + (C : in out Dwarf_Context; + Addr : Address; + Dir_Name : out Str_Access; + File_Name : out Str_Access; + Subprg_Name : out String_Ptr_Len; + Line_Num : out Natural); + -- Symbolize one address + + ----------------------- + -- DWARF constants -- + ----------------------- + + -- 6.2.5.2 Standard Opcodes + + DW_LNS_copy : constant := 1; + DW_LNS_advance_pc : constant := 2; + DW_LNS_advance_line : constant := 3; + DW_LNS_set_file : constant := 4; + DW_LNS_set_column : constant := 5; + DW_LNS_negate_stmt : constant := 6; + DW_LNS_set_basic_block : constant := 7; + DW_LNS_const_add_pc : constant := 8; + DW_LNS_fixed_advance_pc : constant := 9; + DW_LNS_set_prologue_end : constant := 10; + DW_LNS_set_epilogue_begin : constant := 11; + DW_LNS_set_isa : constant := 12; + + -- 6.2.5.3 Extended Opcodes + + DW_LNE_end_sequence : constant := 1; + DW_LNE_set_address : constant := 2; + DW_LNE_define_file : constant := 3; + + -- From the DWARF version 4 public review draft + + DW_LNE_set_discriminator : constant := 4; + + -- Attribute encodings + + DW_TAG_Compile_Unit : constant := 16#11#; + + DW_AT_Stmt_List : constant := 16#10#; + + DW_FORM_addr : constant := 16#01#; + DW_FORM_block2 : constant := 16#03#; + DW_FORM_block4 : constant := 16#04#; + DW_FORM_data2 : constant := 16#05#; + DW_FORM_data4 : constant := 16#06#; + DW_FORM_data8 : constant := 16#07#; + DW_FORM_string : constant := 16#08#; + DW_FORM_block : constant := 16#09#; + DW_FORM_block1 : constant := 16#0a#; + DW_FORM_data1 : constant := 16#0b#; + DW_FORM_flag : constant := 16#0c#; + DW_FORM_sdata : constant := 16#0d#; + DW_FORM_strp : constant := 16#0e#; + DW_FORM_udata : constant := 16#0f#; + DW_FORM_ref_addr : constant := 16#10#; + DW_FORM_ref1 : constant := 16#11#; + DW_FORM_ref2 : constant := 16#12#; + DW_FORM_ref4 : constant := 16#13#; + DW_FORM_ref8 : constant := 16#14#; + DW_FORM_ref_udata : constant := 16#15#; + DW_FORM_indirect : constant := 16#16#; + DW_FORM_sec_offset : constant := 16#17#; + DW_FORM_exprloc : constant := 16#18#; + DW_FORM_flag_present : constant := 16#19#; + DW_FORM_ref_sig8 : constant := 16#20#; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Search_Entry) return Boolean is + begin + return Left.First < Right.First; + end "<"; + + ----------- + -- Close -- + ----------- + + procedure Close (C : in out Dwarf_Context) is + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Object_File, + Object_File_Access); + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Search_Array, + Search_Array_Access); + begin + if C.Has_Debug then + Close (C.Lines); + Close (C.Abbrev); + Close (C.Info); + Close (C.Aranges); + end if; + + Close (C.Obj.all); + Unchecked_Deallocation (C.Obj); + + Unchecked_Deallocation (C.Cache); + end Close; + + ---------- + -- Dump -- + ---------- + + procedure Dump (C : in out Dwarf_Context) is + begin + For_Each_Row (C, Dump_Row'Access); + end Dump; + + -------------- + -- Dump_Row -- + -------------- + + procedure Dump_Row (C : in out Dwarf_Context) is + PC : constant Integer_Address := Integer_Address (C.Registers.Address); + Off : Offset; + begin + Tell (C.Lines, Off); + + Put (System.Address_Image (To_Address (PC))); + Put (" "); + Put (To_File_Name (C, C.Registers.File)); + Put (":"); + + declare + Image : constant String := uint32'Image (C.Registers.Line); + begin + Put_Line (Image (2 .. Image'Last)); + end; + + Seek (C.Lines, Off); + end Dump_Row; + + procedure Dump_Cache (C : Dwarf_Context) is + Cache : constant Search_Array_Access := C.Cache; + S : Object_Symbol; + Name : String_Ptr_Len; + begin + if Cache = null then + Put_Line ("No cache"); + return; + end if; + for I in Cache'Range loop + Put (System.Address_Image (C.Low + Storage_Count (Cache (I).First))); + Put (" - "); + Put + (System.Address_Image + (C.Low + Storage_Count (Cache (I).First + Cache (I).Size))); + Put (" l@"); + Put + (System.Address_Image + (To_Address (Integer_Address (Cache (I).Line)))); + Put (": "); + S := Read_Symbol (C.Obj.all, Offset (Cache (I).Sym)); + Name := Object_Reader.Name (C.Obj.all, S); + Put (String (Name.Ptr (1 .. Name.Len))); + New_Line; + end loop; + end Dump_Cache; + + ------------------ + -- For_Each_Row -- + ------------------ + + procedure For_Each_Row (C : in out Dwarf_Context; F : Callback) is + Done : Boolean; + + begin + Initialize_Pass (C); + + loop + Read_And_Execute_Isn (C, Done); + + if C.Registers.Is_Row then + F.all (C); + end if; + + exit when Done; + end loop; + end For_Each_Row; + + --------------------- + -- Initialize_Pass -- + --------------------- + + procedure Initialize_Pass (C : in out Dwarf_Context) is + begin + Seek (C.Lines, 0); + C.Next_Prologue := 0; + + Initialize_State_Machine (C); + end Initialize_Pass; + + ------------------------------ + -- Initialize_State_Machine -- + ------------------------------ + + procedure Initialize_State_Machine (C : in out Dwarf_Context) is + begin + C.Registers := + (Address => 0, + File => 1, + Line => 1, + Column => 0, + Is_Stmt => C.Prologue.Default_Is_Stmt = 0, + Basic_Block => False, + End_Sequence => False, + Prologue_End => False, + Epilogue_Begin => False, + ISA => 0, + Is_Row => False); + end Initialize_State_Machine; + + --------------- + -- Is_Inside -- + --------------- + + function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is + begin + return Addr >= C.Low and Addr <= C.High; + end Is_Inside; + + --------- + -- Low -- + --------- + + function Low (C : Dwarf_Context) return Address is + begin + return C.Low; + end Low; + + ---------- + -- Open -- + ---------- + + procedure Open + (File_Name : String; + C : out Dwarf_Context; + Success : out Boolean) + is + Line_Sec, Info_Sec, Abbrev_Sec, Aranges_Sec : Object_Section; + Hi, Lo : uint64; + begin + -- Not a success by default + + Success := False; + + -- Open file + + C.Obj := Open (File_Name, C.In_Exception); + + if C.Obj = null then + return; + end if; + + Success := True; + + -- Get memory bounds + + Get_Memory_Bounds (C.Obj.all, Lo, Hi); + C.Low := Address (Lo); + C.High := Address (Hi); + + -- Create a stream for debug sections + + if Format (C.Obj.all) = XCOFF32 then + Line_Sec := Get_Section (C.Obj.all, ".dwline"); + Abbrev_Sec := Get_Section (C.Obj.all, ".dwabrev"); + Info_Sec := Get_Section (C.Obj.all, ".dwinfo"); + Aranges_Sec := Get_Section (C.Obj.all, ".dwarnge"); + else + Line_Sec := Get_Section (C.Obj.all, ".debug_line"); + Abbrev_Sec := Get_Section (C.Obj.all, ".debug_abbrev"); + Info_Sec := Get_Section (C.Obj.all, ".debug_info"); + Aranges_Sec := Get_Section (C.Obj.all, ".debug_aranges"); + end if; + + if Line_Sec = Null_Section + or else Abbrev_Sec = Null_Section + or else Info_Sec = Null_Section + or else Aranges_Sec = Null_Section + then + C.Has_Debug := False; + return; + end if; + + C.Lines := Create_Stream (C.Obj.all, Line_Sec); + C.Abbrev := Create_Stream (C.Obj.all, Abbrev_Sec); + C.Info := Create_Stream (C.Obj.all, Info_Sec); + C.Aranges := Create_Stream (C.Obj.all, Aranges_Sec); + + -- All operations are successful, context is valid + + C.Has_Debug := True; + end Open; + + -------------------- + -- Parse_Prologue -- + -------------------- + + procedure Parse_Prologue (C : in out Dwarf_Context) is + Char : uint8; + Prev : uint8; + -- The most recently read character and the one preceding it + + Dummy : uint32; + -- Destination for reads we don't care about + + Buf : Buffer; + Off : Offset; + + First_Byte_Of_Prologue : Offset; + Last_Byte_Of_Prologue : Offset; + + Max_Op_Per_Insn : uint8; + pragma Unreferenced (Max_Op_Per_Insn); + + Prologue : Line_Info_Prologue renames C.Prologue; + + begin + Tell (C.Lines, First_Byte_Of_Prologue); + Prologue.Unit_Length := Read (C.Lines); + Tell (C.Lines, Off); + C.Next_Prologue := Off + Offset (Prologue.Unit_Length); + + Prologue.Version := Read (C.Lines); + Prologue.Prologue_Length := Read (C.Lines); + Tell (C.Lines, Last_Byte_Of_Prologue); + Last_Byte_Of_Prologue := + Last_Byte_Of_Prologue + Offset (Prologue.Prologue_Length) - 1; + + Prologue.Min_Isn_Length := Read (C.Lines); + + if Prologue.Version >= 4 then + Max_Op_Per_Insn := Read (C.Lines); + end if; + + Prologue.Default_Is_Stmt := Read (C.Lines); + Prologue.Line_Base := Read (C.Lines); + Prologue.Line_Range := Read (C.Lines); + Prologue.Opcode_Base := Read (C.Lines); + + -- Opcode_Lengths is an array of Opcode_Base bytes specifying the number + -- of LEB128 operands for each of the standard opcodes. + + for J in 1 .. uint32 (Prologue.Opcode_Base - 1) loop + Prologue.Opcode_Lengths (J) := Read (C.Lines); + end loop; + + -- The include directories table follows. This is a list of null + -- terminated strings terminated by a double null. We only store + -- its offset for later decoding. + + Tell (C.Lines, Prologue.Includes_Offset); + Char := Read (C.Lines); + + if Char /= 0 then + loop + Prev := Char; + Char := Read (C.Lines); + exit when Char = 0 and Prev = 0; + end loop; + end if; + + -- The file_names table is next. Each record is a null terminated string + -- for the file name, an unsigned LEB128 directory index, an unsigned + -- LEB128 modification time, and an LEB128 file length. The table is + -- terminated by a null byte. + + Tell (C.Lines, Prologue.File_Names_Offset); + + loop + -- Read the filename + + Read_C_String (C.Lines, Buf); + exit when Buf (0) = 0; + Dummy := Read_LEB128 (C.Lines); -- Skip the directory index. + Dummy := Read_LEB128 (C.Lines); -- Skip the modification time. + Dummy := Read_LEB128 (C.Lines); -- Skip the file length. + end loop; + + -- Check we're where we think we are. This sanity check ensures we think + -- the prologue ends where the prologue says it does. It we aren't then + -- we've probably gotten out of sync somewhere. + + Tell (C.Lines, Off); + + if Prologue.Unit_Length /= 0 + and then Off /= Last_Byte_Of_Prologue + 1 + then + raise Dwarf_Error with "Parse error reading DWARF information"; + end if; + end Parse_Prologue; + + -------------------------- + -- Read_And_Execute_Isn -- + -------------------------- + + procedure Read_And_Execute_Isn + (C : in out Dwarf_Context; + Done : out Boolean) + is + Opcode : uint8; + Extended_Opcode : uint8; + uint32_Operand : uint32; + int32_Operand : int32; + uint16_Operand : uint16; + Off : Offset; + + Extended_Length : uint32; + pragma Unreferenced (Extended_Length); + + Obj : Object_File renames C.Obj.all; + Registers : Line_Info_Registers renames C.Registers; + Prologue : Line_Info_Prologue renames C.Prologue; + + begin + Done := False; + Registers.Is_Row := False; + + if Registers.End_Sequence then + Initialize_State_Machine (C); + end if; + + -- Read the next prologue + + Tell (C.Lines, Off); + while Off = C.Next_Prologue loop + Initialize_State_Machine (C); + Parse_Prologue (C); + Tell (C.Lines, Off); + exit when Off + 4 >= Length (C.Lines); + end loop; + + -- Test whether we're done + + Tell (C.Lines, Off); + + -- We are finished when we either reach the end of the section, or we + -- have reached zero padding at the end of the section. + + if Prologue.Unit_Length = 0 or else Off + 4 >= Length (C.Lines) then + Done := True; + return; + end if; + + -- Read and interpret an instruction + + Opcode := Read (C.Lines); + + -- Extended opcodes + + if Opcode = 0 then + Extended_Length := Read_LEB128 (C.Lines); + Extended_Opcode := Read (C.Lines); + + case Extended_Opcode is + when DW_LNE_end_sequence => + + -- Mark the end of a sequence of source locations + + Registers.End_Sequence := True; + Registers.Is_Row := True; + + when DW_LNE_set_address => + + -- Set the program counter to a word + + Registers.Address := Read_Address (Obj, C.Lines); + + when DW_LNE_define_file => + + -- Not implemented + + raise Dwarf_Error with "DWARF operator not implemented"; + + when DW_LNE_set_discriminator => + + -- Ignored + + int32_Operand := Read_LEB128 (C.Lines); + + when others => + + -- Fail on an unrecognized opcode + + raise Dwarf_Error with "DWARF operator not implemented"; + end case; + + -- Standard opcodes + + elsif Opcode < Prologue.Opcode_Base then + case Opcode is + + -- Append a row to the line info matrix + + when DW_LNS_copy => + Registers.Basic_Block := False; + Registers.Is_Row := True; + + -- Add an unsigned word to the program counter + + when DW_LNS_advance_pc => + uint32_Operand := Read_LEB128 (C.Lines); + Registers.Address := + Registers.Address + + uint64 (uint32_Operand * uint32 (Prologue.Min_Isn_Length)); + + -- Add a signed word to the current source line + + when DW_LNS_advance_line => + int32_Operand := Read_LEB128 (C.Lines); + Registers.Line := + uint32 (int32 (Registers.Line) + int32_Operand); + + -- Set the current source file + + when DW_LNS_set_file => + uint32_Operand := Read_LEB128 (C.Lines); + Registers.File := uint32_Operand; + + -- Set the current source column + + when DW_LNS_set_column => + uint32_Operand := Read_LEB128 (C.Lines); + Registers.Column := uint32_Operand; + + -- Toggle the "is statement" flag. GCC doesn't seem to set this??? + + when DW_LNS_negate_stmt => + Registers.Is_Stmt := not Registers.Is_Stmt; + + -- Mark the beginning of a basic block + + when DW_LNS_set_basic_block => + Registers.Basic_Block := True; + + -- Advance the program counter as by the special opcode 255 + + when DW_LNS_const_add_pc => + Registers.Address := + Registers.Address + + uint64 + (((255 - Prologue.Opcode_Base) / Prologue.Line_Range) * + Prologue.Min_Isn_Length); + + -- Advance the program counter by a constant + + when DW_LNS_fixed_advance_pc => + uint16_Operand := Read (C.Lines); + Registers.Address := + Registers.Address + uint64 (uint16_Operand); + + -- The following are not implemented and ignored + + when DW_LNS_set_prologue_end => + null; + + when DW_LNS_set_epilogue_begin => + null; + + when DW_LNS_set_isa => + null; + + -- Anything else is an error + + when others => + raise Dwarf_Error with "DWARF operator not implemented"; + end case; + + -- Decode a special opcode. This is a line and address increment encoded + -- in a single byte 'special opcode' as described in 6.2.5.1. + + else + declare + Address_Increment : int32; + Line_Increment : int32; + + begin + Opcode := Opcode - Prologue.Opcode_Base; + + -- The adjusted opcode is a uint8 encoding an address increment + -- and a signed line increment. The upperbound is allowed to be + -- greater than int8'last so we decode using int32 directly to + -- prevent overflows. + + Address_Increment := + int32 (Opcode / Prologue.Line_Range) * + int32 (Prologue.Min_Isn_Length); + Line_Increment := + int32 (Prologue.Line_Base) + + int32 (Opcode mod Prologue.Line_Range); + + Registers.Address := + Registers.Address + uint64 (Address_Increment); + Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment); + Registers.Basic_Block := False; + Registers.Prologue_End := False; + Registers.Epilogue_Begin := False; + Registers.Is_Row := True; + end; + end if; + + exception + when Dwarf_Error => + + -- In case of errors during parse, just stop reading + + Registers.Is_Row := False; + Done := True; + end Read_And_Execute_Isn; + + ---------------------- + -- Set_Load_Address -- + ---------------------- + + procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is + begin + if Addr = Null_Address then + return; + else + C.Load_Slide := + To_Integer (Addr) - Integer_Address (Get_Load_Address (C.Obj.all)); + + C.Low := To_Address (To_Integer (C.Low) + C.Load_Slide); + C.High := To_Address (To_Integer (C.High) + C.Load_Slide); + end if; + end Set_Load_Address; + + ------------------ + -- To_File_Name -- + ------------------ + + function To_File_Name + (C : in out Dwarf_Context; + Code : uint32) return String + is + Buf : Buffer; + J : uint32; + + Dir_Idx : uint32; + pragma Unreferenced (Dir_Idx); + + Mod_Time : uint32; + pragma Unreferenced (Mod_Time); + + Length : uint32; + pragma Unreferenced (Length); + + begin + Seek (C.Lines, C.Prologue.File_Names_Offset); + + -- Find the entry + + J := 0; + loop + J := J + 1; + Read_C_String (C.Lines, Buf); + + if Buf (Buf'First) = 0 then + return "???"; + end if; + + Dir_Idx := Read_LEB128 (C.Lines); + Mod_Time := Read_LEB128 (C.Lines); + Length := Read_LEB128 (C.Lines); + exit when J = Code; + end loop; + + return To_String (Buf); + end To_File_Name; + + ------------------------- + -- Read_Initial_Length -- + ------------------------- + + procedure Read_Initial_Length + (S : in out Mapped_Stream; + Len : out Offset; + Is64 : out Boolean) + is + Len32 : uint32; + Len64 : uint64; + begin + Len32 := Read (S); + if Len32 < 16#ffff_fff0# then + Is64 := False; + Len := Offset (Len32); + elsif Len32 < 16#ffff_ffff# then + -- Invalid length + raise Constraint_Error; + else + Is64 := True; + Len64 := Read (S); + Len := Offset (Len64); + end if; + end Read_Initial_Length; + + ------------------------- + -- Read_Section_Offset -- + ------------------------- + + procedure Read_Section_Offset + (S : in out Mapped_Stream; + Len : out Offset; + Is64 : Boolean) + is + begin + if Is64 then + Len := Offset (uint64'(Read (S))); + else + Len := Offset (uint32'(Read (S))); + end if; + end Read_Section_Offset; + + -------------------- + -- Aranges_Lookup -- + -------------------- + + procedure Aranges_Lookup + (C : in out Dwarf_Context; + Addr : Address; + Info_Offset : out Offset; + Success : out Boolean) + is + begin + Seek (C.Aranges, 0); + + while Tell (C.Aranges) < Length (C.Aranges) loop + Read_Aranges_Header (C, Info_Offset, Success); + exit when not Success; + + loop + declare + Start : Integer_Address; + Len : Storage_Count; + begin + Read_Aranges_Entry (C, Start, Len); + exit when Start = 0 and Len = 0; + if Addr >= To_Address (Start) + and then Addr < To_Address (Start) + Len + then + Success := True; + return; + end if; + end; + end loop; + end loop; + Success := False; + end Aranges_Lookup; + + --------------- + -- Skip_Form -- + --------------- + + procedure Skip_Form + (S : in out Mapped_Stream; + Form : uint32; + Is64 : Boolean; + Ptr_Sz : uint8) + is + Skip : Offset; + begin + case Form is + when DW_FORM_addr => + Skip := Offset (Ptr_Sz); + when DW_FORM_block2 => + Skip := Offset (uint16'(Read (S))); + when DW_FORM_block4 => + Skip := Offset (uint32'(Read (S))); + when DW_FORM_data2 | DW_FORM_ref2 => + Skip := 2; + when DW_FORM_data4 | DW_FORM_ref4 => + Skip := 4; + when DW_FORM_data8 | DW_FORM_ref8 | DW_FORM_ref_sig8 => + Skip := 8; + when DW_FORM_string => + while uint8'(Read (S)) /= 0 loop + null; + end loop; + return; + when DW_FORM_block | DW_FORM_exprloc => + Skip := Offset (uint32'(Read_LEB128 (S))); + when DW_FORM_block1 | DW_FORM_ref1 => + Skip := Offset (uint8'(Read (S))); + when DW_FORM_data1 | DW_FORM_flag => + Skip := 1; + when DW_FORM_sdata => + declare + Val : constant int32 := Read_LEB128 (S); + pragma Unreferenced (Val); + begin + return; + end; + when DW_FORM_strp | DW_FORM_ref_addr | DW_FORM_sec_offset => + Skip := (if Is64 then 8 else 4); + when DW_FORM_udata | DW_FORM_ref_udata => + declare + Val : constant uint32 := Read_LEB128 (S); + pragma Unreferenced (Val); + begin + return; + end; + when DW_FORM_flag_present => + return; + when DW_FORM_indirect => + raise Constraint_Error; + when others => + raise Constraint_Error; + end case; + Seek (S, Tell (S) + Skip); + end Skip_Form; + + ----------------- + -- Seek_Abbrev -- + ----------------- + + procedure Seek_Abbrev + (C : in out Dwarf_Context; + Abbrev_Offset : Offset; + Abbrev_Num : uint32) + is + Num : uint32; + Abbrev : uint32; + Tag : uint32; + Has_Child : uint8; + pragma Unreferenced (Abbrev, Tag, Has_Child); + begin + Seek (C.Abbrev, Abbrev_Offset); + + Num := 1; + + loop + exit when Num = Abbrev_Num; + + Abbrev := Read_LEB128 (C.Abbrev); + Tag := Read_LEB128 (C.Abbrev); + Has_Child := Read (C.Abbrev); + + loop + declare + Name : constant uint32 := Read_LEB128 (C.Abbrev); + Form : constant uint32 := Read_LEB128 (C.Abbrev); + begin + exit when Name = 0 and Form = 0; + end; + end loop; + + Num := Num + 1; + end loop; + end Seek_Abbrev; + + ----------------------- + -- Debug_Info_Lookup -- + ----------------------- + + procedure Debug_Info_Lookup + (C : in out Dwarf_Context; + Info_Offset : Offset; + Line_Offset : out Offset; + Success : out Boolean) + is + Unit_Length : Offset; + Is64 : Boolean; + Version : uint16; + Abbrev_Offset : Offset; + Addr_Sz : uint8; + Abbrev : uint32; + Has_Child : uint8; + pragma Unreferenced (Has_Child); + begin + Success := False; + + Seek (C.Info, Info_Offset); + + Read_Initial_Length (C.Info, Unit_Length, Is64); + + Version := Read (C.Info); + if Version not in 2 .. 4 then + return; + end if; + + Read_Section_Offset (C.Info, Abbrev_Offset, Is64); + + Addr_Sz := Read (C.Info); + if Addr_Sz /= (Address'Size / SSU) then + return; + end if; + + -- Read DIEs + + loop + Abbrev := Read_LEB128 (C.Info); + exit when Abbrev /= 0; + end loop; + + -- Read abbrev table + + Seek_Abbrev (C, Abbrev_Offset, Abbrev); + + -- First ULEB128 is the abbrev code + + if Read_LEB128 (C.Abbrev) /= Abbrev then + -- Ill formed abbrev table + return; + end if; + + -- Then the tag + + if Read_LEB128 (C.Abbrev) /= uint32'(DW_TAG_Compile_Unit) then + -- Expect compile unit + return; + end if; + + -- Then the has child flag + + Has_Child := Read (C.Abbrev); + + loop + declare + Name : constant uint32 := Read_LEB128 (C.Abbrev); + Form : constant uint32 := Read_LEB128 (C.Abbrev); + begin + exit when Name = 0 and Form = 0; + if Name = DW_AT_Stmt_List then + case Form is + when DW_FORM_sec_offset => + Read_Section_Offset (C.Info, Line_Offset, Is64); + when DW_FORM_data4 => + Line_Offset := Offset (uint32'(Read (C.Info))); + when DW_FORM_data8 => + Line_Offset := Offset (uint64'(Read (C.Info))); + when others => + -- Unhandled form + return; + end case; + + Success := True; + return; + else + Skip_Form (C.Info, Form, Is64, Addr_Sz); + end if; + end; + end loop; + + return; + end Debug_Info_Lookup; + + ------------------------- + -- Read_Aranges_Header -- + ------------------------- + + procedure Read_Aranges_Header + (C : in out Dwarf_Context; + Info_Offset : out Offset; + Success : out Boolean) + is + Unit_Length : Offset; + Is64 : Boolean; + Version : uint16; + Sz : uint8; + begin + Success := False; + + Read_Initial_Length (C.Aranges, Unit_Length, Is64); + + Version := Read (C.Aranges); + if Version /= 2 then + return; + end if; + + Read_Section_Offset (C.Aranges, Info_Offset, Is64); + + -- Read address_size (ubyte) + + Sz := Read (C.Aranges); + if Sz /= (Address'Size / SSU) then + return; + end if; + + -- Read segment_size (ubyte) + + Sz := Read (C.Aranges); + if Sz /= 0 then + return; + end if; + + -- Handle alignment on twice the address size + declare + Cur_Off : constant Offset := Tell (C.Aranges); + Align : constant Offset := 2 * Address'Size / SSU; + Space : constant Offset := Cur_Off mod Align; + begin + if Space /= 0 then + Seek (C.Aranges, Cur_Off + Align - Space); + end if; + end; + + Success := True; + end Read_Aranges_Header; + + ------------------------ + -- Read_Aranges_Entry -- + ------------------------ + + procedure Read_Aranges_Entry + (C : in out Dwarf_Context; + Start : out Integer_Address; + Len : out Storage_Count) + is + begin + -- Read table + if Address'Size = 32 then + declare + S, L : uint32; + begin + S := Read (C.Aranges); + L := Read (C.Aranges); + Start := Integer_Address (S); + Len := Storage_Count (L); + end; + elsif Address'Size = 64 then + declare + S, L : uint64; + begin + S := Read (C.Aranges); + L := Read (C.Aranges); + Start := Integer_Address (S); + Len := Storage_Count (L); + end; + else + raise Constraint_Error; + end if; + end Read_Aranges_Entry; + + ------------------ + -- Enable_Cache -- + ------------------ + + procedure Enable_Cache (C : in out Dwarf_Context) is + Cache : Search_Array_Access; + begin + -- Phase 1: count number of symbols. Phase 2: fill the cache. + declare + S : Object_Symbol; + Sz : uint32; + Addr, Prev_Addr : uint32; + Nbr_Symbols : Natural; + begin + for Phase in 1 .. 2 loop + Nbr_Symbols := 0; + S := First_Symbol (C.Obj.all); + Prev_Addr := uint32'Last; + while S /= Null_Symbol loop + -- Discard symbols whose length is 0 + Sz := uint32 (Size (S)); + + -- Try to filter symbols at the same address. This is a best + -- effort as they might not be consecutive. + Addr := uint32 (Value (S) - uint64 (C.Low)); + if Sz > 0 and then Addr /= Prev_Addr then + Nbr_Symbols := Nbr_Symbols + 1; + Prev_Addr := Addr; + + if Phase = 2 then + C.Cache (Nbr_Symbols) := + (First => Addr, + Size => Sz, + Sym => uint32 (Off (S)), + Line => 0); + end if; + end if; + + S := Next_Symbol (C.Obj.all, S); + end loop; + + if Phase = 1 then + -- Allocate the cache + Cache := new Search_Array (1 .. Nbr_Symbols); + C.Cache := Cache; + end if; + end loop; + pragma Assert (Nbr_Symbols = C.Cache'Last); + end; + + -- Sort the cache. + Sort_Search_Array (C.Cache.all); + + -- Set line offsets + if not C.Has_Debug then + return; + end if; + declare + Info_Offset : Offset; + Line_Offset : Offset; + Success : Boolean; + Ar_Start : Integer_Address; + Ar_Len : Storage_Count; + Start, Len : uint32; + First, Last : Natural; + Mid : Natural; + begin + Seek (C.Aranges, 0); + + while Tell (C.Aranges) < Length (C.Aranges) loop + Read_Aranges_Header (C, Info_Offset, Success); + exit when not Success; + + Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); + exit when not Success; + + -- Read table + loop + Read_Aranges_Entry (C, Ar_Start, Ar_Len); + exit when Ar_Start = 0 and Ar_Len = 0; + + Len := uint32 (Ar_Len); + Start := uint32 (Ar_Start - To_Integer (C.Low)); + + -- Search START in the array + First := Cache'First; + Last := Cache'Last; + Mid := First; -- In case of array with one element + while First < Last loop + Mid := First + (Last - First) / 2; + if Start < Cache (Mid).First then + Last := Mid - 1; + elsif Start >= Cache (Mid).First + Cache (Mid).Size then + First := Mid + 1; + else + exit; + end if; + end loop; + + -- Fill info. + + -- There can be overlapping symbols + while Mid > Cache'First + and then Cache (Mid - 1).First <= Start + and then Cache (Mid - 1).First + Cache (Mid - 1).Size > Start + loop + Mid := Mid - 1; + end loop; + while Mid <= Cache'Last loop + if Start < Cache (Mid).First + Cache (Mid).Size + and then Start + Len > Cache (Mid).First + then + -- MID is within the bounds + Cache (Mid).Line := uint32 (Line_Offset); + elsif Start + Len <= Cache (Mid).First then + -- Over + exit; + end if; + Mid := Mid + 1; + end loop; + end loop; + end loop; + end; + end Enable_Cache; + + ---------------------- + -- Symbolic_Address -- + ---------------------- + + procedure Symbolic_Address + (C : in out Dwarf_Context; + Addr : Address; + Dir_Name : out Str_Access; + File_Name : out Str_Access; + Subprg_Name : out String_Ptr_Len; + Line_Num : out Natural) + is + procedure Set_Result (Match : Line_Info_Registers); + -- Set results using match + + procedure Set_Result (Match : Line_Info_Registers) is + Dir_Idx : uint32; + J : uint32; + + Mod_Time : uint32; + pragma Unreferenced (Mod_Time); + + Length : uint32; + pragma Unreferenced (Length); + + begin + Seek (C.Lines, C.Prologue.File_Names_Offset); + + -- Find the entry + + J := 0; + loop + J := J + 1; + File_Name := Read_C_String (C.Lines); + + if File_Name (File_Name'First) = ASCII.NUL then + -- End of file list, so incorrect entry + return; + end if; + + Dir_Idx := Read_LEB128 (C.Lines); + Mod_Time := Read_LEB128 (C.Lines); + Length := Read_LEB128 (C.Lines); + exit when J = Match.File; + end loop; + + if Dir_Idx = 0 then + -- No directory + Dir_Name := null; + + else + Seek (C.Lines, C.Prologue.Includes_Offset); + + J := 0; + loop + J := J + 1; + Dir_Name := Read_C_String (C.Lines); + + if Dir_Name (Dir_Name'First) = ASCII.NUL then + -- End of directory list, so ill-formed table + return; + end if; + + exit when J = Dir_Idx; + + end loop; + end if; + + Line_Num := Natural (Match.Line); + end Set_Result; + + Addr_Int : constant Integer_Address := To_Integer (Addr); + Previous_Row : Line_Info_Registers; + Info_Offset : Offset; + Line_Offset : Offset; + Success : Boolean; + Done : Boolean; + S : Object_Symbol; + begin + -- Initialize result + Dir_Name := null; + File_Name := null; + Subprg_Name := (null, 0); + Line_Num := 0; + + if C.Cache /= null then + -- Look in the cache + declare + Addr_Off : constant uint32 := uint32 (Addr - C.Low); + First, Last, Mid : Natural; + begin + First := C.Cache'First; + Last := C.Cache'Last; + while First <= Last loop + Mid := First + (Last - First) / 2; + if Addr_Off < C.Cache (Mid).First then + Last := Mid - 1; + elsif Addr_Off >= C.Cache (Mid).First + C.Cache (Mid).Size then + First := Mid + 1; + else + exit; + end if; + end loop; + if Addr_Off >= C.Cache (Mid).First + and then Addr_Off < C.Cache (Mid).First + C.Cache (Mid).Size + then + Line_Offset := Offset (C.Cache (Mid).Line); + S := Read_Symbol (C.Obj.all, Offset (C.Cache (Mid).Sym)); + Subprg_Name := Object_Reader.Name (C.Obj.all, S); + else + -- Not found + return; + end if; + end; + else + -- Search symbol + S := First_Symbol (C.Obj.all); + while S /= Null_Symbol loop + if Spans (S, uint64 (Addr_Int)) then + Subprg_Name := Object_Reader.Name (C.Obj.all, S); + exit; + end if; + + S := Next_Symbol (C.Obj.all, S); + end loop; + + -- Search address in aranges table + + Aranges_Lookup (C, Addr, Info_Offset, Success); + if not Success then + return; + end if; + + -- Search stmt_list in info table + + Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); + if not Success then + return; + end if; + end if; + + Seek (C.Lines, Line_Offset); + C.Next_Prologue := 0; + Initialize_State_Machine (C); + Parse_Prologue (C); + + -- Advance to the first entry + + loop + Read_And_Execute_Isn (C, Done); + + if C.Registers.Is_Row then + Previous_Row := C.Registers; + exit; + end if; + + exit when Done; + end loop; + + -- Read the rest of the entries + + while Tell (C.Lines) < C.Next_Prologue loop + Read_And_Execute_Isn (C, Done); + + if C.Registers.Is_Row then + if not Previous_Row.End_Sequence + and then Addr_Int >= Integer_Address (Previous_Row.Address) + and then Addr_Int < Integer_Address (C.Registers.Address) + then + Set_Result (Previous_Row); + return; + + elsif Addr_Int = Integer_Address (C.Registers.Address) then + Set_Result (C.Registers); + return; + end if; + + Previous_Row := C.Registers; + end if; + + exit when Done; + end loop; + end Symbolic_Address; + + ------------------- + -- String_Length -- + ------------------- + + function String_Length (Str : Str_Access) return Natural is + begin + for I in Str'Range loop + if Str (I) = ASCII.NUL then + return I - Str'First; + end if; + end loop; + return Str'Last; + end String_Length; + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + procedure Symbolic_Traceback + (Cin : Dwarf_Context; + Traceback : AET.Tracebacks_Array; + Suppress_Hex : Boolean; + Symbol_Found : in out Boolean; + Res : in out System.Bounded_Strings.Bounded_String) + is + use Ada.Characters.Handling; + C : Dwarf_Context := Cin; + Addr : Address; + + Dir_Name : Str_Access; + File_Name : Str_Access; + Subprg_Name : String_Ptr_Len; + Line_Num : Natural; + Off : Natural; + begin + if not C.Has_Debug then + Symbol_Found := False; + return; + else + Symbol_Found := True; + end if; + + for J in Traceback'Range loop + -- If the buffer is full, no need to do any useless work + exit when Is_Full (Res); + + Addr := PC_For (Traceback (J)); + Symbolic_Address + (C, + To_Address (To_Integer (Addr) + C.Load_Slide), + Dir_Name, + File_Name, + Subprg_Name, + Line_Num); + + if File_Name /= null then + declare + Last : constant Natural := String_Length (File_Name); + Is_Ada : constant Boolean := + Last > 3 + and then + To_Upper (String (File_Name (Last - 3 .. Last - 1))) = + ".AD"; + -- True if this is an Ada file. This doesn't take into account + -- nonstandard file-naming conventions, but that's OK; this is + -- purely cosmetic. It covers at least .ads, .adb, and .ada. + + Line_Image : constant String := Natural'Image (Line_Num); + begin + if Subprg_Name.Len /= 0 then + -- For Ada code, Symbol_Image is in all lower case; we don't + -- have the case from the original source code. But the best + -- guess is Mixed_Case, so convert to that. + + if Is_Ada then + declare + Symbol_Image : String := + Object_Reader.Decoded_Ada_Name + (C.Obj.all, + Subprg_Name); + begin + for K in Symbol_Image'Range loop + if K = Symbol_Image'First + or else not + (Is_Letter (Symbol_Image (K - 1)) + or else Is_Digit (Symbol_Image (K - 1))) + then + Symbol_Image (K) := To_Upper (Symbol_Image (K)); + end if; + end loop; + Append (Res, Symbol_Image); + end; + else + Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); + + Append + (Res, + String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); + end if; + Append (Res, ' '); + end if; + + Append (Res, "at "); + Append (Res, String (File_Name (1 .. Last))); + Append (Res, ':'); + Append (Res, Line_Image (2 .. Line_Image'Last)); + end; + else + if Suppress_Hex then + Append (Res, "..."); + else + Append_Address (Res, Addr); + end if; + + if Subprg_Name.Len > 0 then + Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); + + Append (Res, ' '); + Append (Res, String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); + end if; + + Append (Res, " at ???"); + end if; + + Append (Res, ASCII.LF); + end loop; + end Symbolic_Traceback; +end System.Dwarf_Lines;