| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
| -- -- |
| -- As a special exception under Section 7 of GPL version 3, you are granted -- |
| -- additional permissions described in the GCC Runtime Library Exception, -- |
| -- version 3.1, as published by the Free Software Foundation. -- |
| -- -- |
| -- You should have received a copy of the GNU General Public License and -- |
| -- a copy of the GCC Runtime Library Exception along with this program; -- |
| -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Ada.Characters.Handling; |
| with Ada.Containers.Generic_Array_Sort; |
| with Ada.Unchecked_Deallocation; |
| |
| with Interfaces; use Interfaces; |
| |
| with System.Address_Image; |
| with System.Bounded_Strings; use System.Bounded_Strings; |
| with System.IO; use System.IO; |
| with System.Mmap; use System.Mmap; |
| with System.Object_Reader; use System.Object_Reader; |
| with System.Storage_Elements; use System.Storage_Elements; |
| |
| package body System.Dwarf_Lines is |
| |
| SSU : constant := System.Storage_Unit; |
| |
| function Get_Load_Displacement (C : Dwarf_Context) return Storage_Offset; |
| -- Return the displacement between the load address present in the binary |
| -- and the run-time address at which it is loaded (i.e. non-zero for PIE). |
| |
| 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 7.2.2 |
| |
| procedure Read_Section_Offset |
| (S : in out Mapped_Stream; |
| Len : out Offset; |
| Is64 : Boolean); |
| -- Read a section offset, as specified by 7.4 |
| |
| procedure Read_Entry_Format_Array |
| (S : in out Mapped_Stream; |
| A : out Entry_Format_Array; |
| Len : uint8); |
| -- Read an entry format array, as specified by 6.2.4.1 |
| |
| procedure Read_Aranges_Entry |
| (C : in out Dwarf_Context; |
| Start : out 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 header 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_Header (C : in out Dwarf_Context); |
| -- Decode a DWARF statement program header |
| |
| procedure Read_And_Execute_Insn |
| (C : in out Dwarf_Context; |
| Done : out Boolean); |
| -- Read an execute a statement program instruction |
| |
| function To_File_Name |
| (C : in out Dwarf_Context; |
| File : uint32) return String; |
| -- Extract a file name from the header |
| |
| type Callback is not null 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 -- |
| ----------------------- |
| |
| -- 3.1.1 Full and Partial Compilation Unit Entries |
| |
| DW_TAG_Compile_Unit : constant := 16#11#; |
| |
| DW_AT_Stmt_List : constant := 16#10#; |
| |
| -- 6.2.4.1 Standard Content Descriptions (DWARF 5) |
| |
| DW_LNCT_path : constant := 1; |
| DW_LNCT_directory_index : constant := 2; |
| -- DW_LNCT_timestamp : constant := 3; |
| -- DW_LNCT_size : constant := 4; |
| DW_LNCT_MD5 : constant := 5; |
| DW_LNCT_lo_user : constant := 16#2000#; |
| DW_LNCT_hi_user : constant := 16#3fff#; |
| |
| -- 6.2.5.2 Standard Opcodes |
| |
| DW_LNS_extended_op : constant := 0; |
| 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; |
| DW_LNE_set_discriminator : constant := 4; |
| |
| -- 7.5.5 Classes and Forms |
| |
| 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_strx : constant := 16#1a#; |
| DW_FORM_addrx : constant := 16#1b#; |
| DW_FORM_ref_sup4 : constant := 16#1c#; |
| DW_FORM_strp_sup : constant := 16#1d#; |
| DW_FORM_data16 : constant := 16#1e#; |
| DW_FORM_line_strp : constant := 16#1f#; |
| DW_FORM_ref_sig8 : constant := 16#20#; |
| DW_FORM_implicit_const : constant := 16#21#; |
| DW_FORM_loclistx : constant := 16#22#; |
| DW_FORM_rnglistx : constant := 16#23#; |
| DW_FORM_ref_sup8 : constant := 16#24#; |
| DW_FORM_strx1 : constant := 16#25#; |
| DW_FORM_strx2 : constant := 16#26#; |
| DW_FORM_strx3 : constant := 16#27#; |
| DW_FORM_strx4 : constant := 16#28#; |
| DW_FORM_addrx1 : constant := 16#29#; |
| DW_FORM_addrx2 : constant := 16#2a#; |
| DW_FORM_addrx3 : constant := 16#2b#; |
| DW_FORM_addrx4 : constant := 16#2c#; |
| |
| --------- |
| -- "<" -- |
| --------- |
| |
| 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 |
| declare |
| E : Search_Entry renames Cache (I); |
| Base_Address : constant System.Address := |
| To_Address (Integer_Address (C.Low + Storage_Count (E.First))); |
| begin |
| Put (System.Address_Image (Base_Address)); |
| Put (" - "); |
| Put (System.Address_Image (Base_Address + Storage_Count (E.Size))); |
| Put (" l@"); |
| Put (System.Address_Image (To_Address (Integer_Address (E.Line)))); |
| Put (": "); |
| S := Read_Symbol (C.Obj.all, Offset (E.Sym)); |
| Name := Object_Reader.Name (C.Obj.all, S); |
| Put (String (Name.Ptr (1 .. Name.Len))); |
| New_Line; |
| end; |
| 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_Insn (C, Done); |
| |
| if C.Registers.Is_Row then |
| F.all (C); |
| end if; |
| |
| exit when Done; |
| end loop; |
| end For_Each_Row; |
| |
| --------------------------- |
| -- Get_Load_Displacement -- |
| --------------------------- |
| |
| function Get_Load_Displacement (C : Dwarf_Context) return Storage_Offset is |
| begin |
| if C.Load_Address /= Null_Address then |
| return C.Load_Address - Address (Get_Load_Address (C.Obj.all)); |
| else |
| return 0; |
| end if; |
| end Get_Load_Displacement; |
| |
| --------------------- |
| -- Initialize_Pass -- |
| --------------------- |
| |
| procedure Initialize_Pass (C : in out Dwarf_Context) is |
| begin |
| Seek (C.Lines, 0); |
| C.Next_Header := 0; |
| Initialize_State_Machine (C); |
| end Initialize_Pass; |
| |
| ------------------------------ |
| -- Initialize_State_Machine -- |
| ------------------------------ |
| |
| procedure Initialize_State_Machine (C : in out Dwarf_Context) is |
| begin |
| -- Table 6.4: Line number program initial state |
| |
| C.Registers := |
| (Address => 0, |
| File => 1, |
| Line => 1, |
| Column => 0, |
| Is_Stmt => C.Header.Default_Is_Stmt /= 0, |
| Basic_Block => False, |
| End_Sequence => False, |
| Is_Row => False); |
| end Initialize_State_Machine; |
| |
| --------------- |
| -- Is_Inside -- |
| --------------- |
| |
| function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is |
| Disp : constant Storage_Offset := Get_Load_Displacement (C); |
| |
| begin |
| return Addr >= C.Low + Disp and then Addr <= C.High + Disp; |
| end Is_Inside; |
| |
| ----------------- |
| -- Low_Address -- |
| ----------------- |
| |
| function Low_Address (C : Dwarf_Context) return Address is |
| begin |
| return C.Low + Get_Load_Displacement (C); |
| end Low_Address; |
| |
| ---------- |
| -- Open -- |
| ---------- |
| |
| procedure Open |
| (File_Name : String; |
| C : out Dwarf_Context; |
| Success : out Boolean) |
| is |
| Abbrev, Aranges, Lines, Info, Line_Str : Object_Section; |
| Hi, Lo : uint64; |
| |
| begin |
| -- Not a success by default |
| |
| Success := False; |
| |
| -- Open file with In_Exception set so we can control the failure mode |
| |
| C.Obj := Open (File_Name, In_Exception => True); |
| |
| if C.Obj = null then |
| if C.In_Exception then |
| return; |
| else |
| raise Dwarf_Error with "could not open file"; |
| end if; |
| end if; |
| |
| Success := True; |
| |
| -- Get address bounds for executable code. Note that such code |
| -- might come from multiple sections. |
| |
| Get_Xcode_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 |
| Abbrev := Get_Section (C.Obj.all, ".dwabrev"); |
| Aranges := Get_Section (C.Obj.all, ".dwarnge"); |
| Info := Get_Section (C.Obj.all, ".dwinfo"); |
| Lines := Get_Section (C.Obj.all, ".dwline"); |
| Line_Str := Get_Section (C.Obj.all, ".dwlistr"); |
| else |
| Abbrev := Get_Section (C.Obj.all, ".debug_abbrev"); |
| Aranges := Get_Section (C.Obj.all, ".debug_aranges"); |
| Info := Get_Section (C.Obj.all, ".debug_info"); |
| Lines := Get_Section (C.Obj.all, ".debug_line"); |
| Line_Str := Get_Section (C.Obj.all, ".debug_line_str"); |
| end if; |
| |
| if Abbrev = Null_Section |
| or else Aranges = Null_Section |
| or else Info = Null_Section |
| or else Lines = Null_Section |
| then |
| pragma Annotate |
| (CodePeer, False_Positive, |
| "test always true", "codepeer got confused"); |
| |
| C.Has_Debug := False; |
| return; |
| end if; |
| |
| C.Abbrev := Create_Stream (C.Obj.all, Abbrev); |
| C.Aranges := Create_Stream (C.Obj.all, Aranges); |
| C.Info := Create_Stream (C.Obj.all, Info); |
| C.Lines := Create_Stream (C.Obj.all, Lines); |
| |
| -- The .debug_line_str section may be available in DWARF 5 |
| |
| if Line_Str /= Null_Section then |
| C.Line_Str := Create_Stream (C.Obj.all, Line_Str); |
| end if; |
| |
| -- All operations are successful, context is valid |
| |
| C.Has_Debug := True; |
| end Open; |
| |
| ------------------ |
| -- Parse_Header -- |
| ------------------ |
| |
| procedure Parse_Header (C : in out Dwarf_Context) is |
| Header : Line_Info_Header renames C.Header; |
| |
| 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_Header : Offset; |
| Last_Byte_Of_Header : Offset; |
| |
| Standard_Opcode_Lengths : Opcode_Length_Array; |
| pragma Unreferenced (Standard_Opcode_Lengths); |
| |
| begin |
| Tell (C.Lines, First_Byte_Of_Header); |
| |
| Read_Initial_Length (C.Lines, Header.Unit_Length, Header.Is64); |
| |
| Tell (C.Lines, Off); |
| C.Next_Header := Off + Header.Unit_Length; |
| |
| Header.Version := Read (C.Lines); |
| |
| if Header.Version >= 5 then |
| Header.Address_Size := Read (C.Lines); |
| Header.Segment_Selector_Size := Read (C.Lines); |
| else |
| Header.Address_Size := 0; |
| Header.Segment_Selector_Size := 0; |
| end if; |
| |
| Header.Header_Length := Read (C.Lines); |
| Tell (C.Lines, Last_Byte_Of_Header); |
| Last_Byte_Of_Header := |
| Last_Byte_Of_Header + Offset (Header.Header_Length) - 1; |
| |
| Header.Minimum_Insn_Length := Read (C.Lines); |
| |
| if Header.Version >= 4 then |
| Header.Maximum_Op_Per_Insn := Read (C.Lines); |
| else |
| Header.Maximum_Op_Per_Insn := 0; |
| end if; |
| |
| Header.Default_Is_Stmt := Read (C.Lines); |
| Header.Line_Base := Read (C.Lines); |
| Header.Line_Range := Read (C.Lines); |
| Header.Opcode_Base := Read (C.Lines); |
| |
| -- Standard_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 .. Integer (Header.Opcode_Base - 1) loop |
| Standard_Opcode_Lengths (J) := Read (C.Lines); |
| end loop; |
| |
| -- The Directories table follows. Up to DWARF 4, this is a list of null |
| -- terminated strings terminated by a null byte. In DWARF 5, this is a |
| -- sequence of Directories_Count entries which are encoded as described |
| -- by the Directory_Entry_Format field. We store its offset for later. |
| |
| if Header.Version <= 4 then |
| Tell (C.Lines, Header.Directories); |
| 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; |
| |
| else |
| Header.Directory_Entry_Format_Count := Read (C.Lines); |
| Read_Entry_Format_Array (C.Lines, |
| Header.Directory_Entry_Format, |
| Header.Directory_Entry_Format_Count); |
| |
| Header.Directories_Count := Read_LEB128 (C.Lines); |
| Tell (C.Lines, Header.Directories); |
| for J in 1 .. Header.Directories_Count loop |
| for K in 1 .. Integer (Header.Directory_Entry_Format_Count) loop |
| Skip_Form (C.Lines, |
| Header.Directory_Entry_Format (K).Form, |
| Header.Is64, |
| Header.Address_Size); |
| end loop; |
| end loop; |
| end if; |
| |
| -- The File_Names table is next. Up to DWARF 4, this is a list of record |
| -- containing a null terminated string for the file name, an unsigned |
| -- LEB128 directory index in the Directories table, an unsigned LEB128 |
| -- modification time, and an unsigned LEB128 for the file length; the |
| -- table is terminated by a null byte. In DWARF 5, this is a sequence |
| -- of File_Names_Count entries which are encoded as described by the |
| -- File_Name_Entry_Format field. We store its offset for later decoding. |
| |
| if Header.Version <= 4 then |
| Tell (C.Lines, Header.File_Names); |
| |
| -- Read the file names |
| |
| loop |
| 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; |
| |
| else |
| Header.File_Name_Entry_Format_Count := Read (C.Lines); |
| Read_Entry_Format_Array (C.Lines, |
| Header.File_Name_Entry_Format, |
| Header.File_Name_Entry_Format_Count); |
| |
| Header.File_Names_Count := Read_LEB128 (C.Lines); |
| Tell (C.Lines, Header.File_Names); |
| for J in 1 .. Header.File_Names_Count loop |
| for K in 1 .. Integer (Header.File_Name_Entry_Format_Count) loop |
| Skip_Form (C.Lines, |
| Header.File_Name_Entry_Format (K).Form, |
| Header.Is64, |
| Header.Address_Size); |
| end loop; |
| end loop; |
| end if; |
| |
| -- Check we're where we think we are. This sanity check ensures we think |
| -- the header ends where the header says it does. It we aren't, then we |
| -- have probably gotten out of sync somewhere. |
| |
| Tell (C.Lines, Off); |
| |
| if Header.Unit_Length /= 0 |
| and then Off /= Last_Byte_Of_Header + 1 |
| then |
| raise Dwarf_Error with "parse error reading DWARF information"; |
| end if; |
| end Parse_Header; |
| |
| --------------------------- |
| -- Read_And_Execute_Insn -- |
| --------------------------- |
| |
| procedure Read_And_Execute_Insn |
| (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; |
| Header : Line_Info_Header renames C.Header; |
| |
| begin |
| Done := False; |
| Registers.Is_Row := False; |
| |
| if Registers.End_Sequence then |
| Initialize_State_Machine (C); |
| end if; |
| |
| -- If we have reached the next header, read it. Beware of possibly empty |
| -- blocks. |
| |
| -- When testing for the end of section, beware of possible zero padding |
| -- at the end. Bail out as soon as there's not even room for at least a |
| -- DW_LNE_end_sequence, 3 bytes from Off to Off+2. This resolves to |
| -- Off+2 > Last_Offset_Within_Section, that is Off+2 > Section_Length-1, |
| -- or Off+3 > Section_Length. |
| |
| Tell (C.Lines, Off); |
| while Off = C.Next_Header loop |
| Initialize_State_Machine (C); |
| Parse_Header (C); |
| Tell (C.Lines, Off); |
| exit when Off + 3 > 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 Header.Unit_Length = 0 or else Off + 3 > Length (C.Lines) then |
| Done := True; |
| return; |
| end if; |
| |
| -- Read and interpret an instruction |
| |
| Opcode := Read (C.Lines); |
| |
| -- Extended opcodes |
| |
| if Opcode = DW_LNS_extended_op 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 < Header.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 (Header.Minimum_Insn_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 - Header.Opcode_Base) / Header.Line_Range) * |
| Header.Minimum_Insn_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 - Header.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 / Header.Line_Range) * |
| int32 (Header.Minimum_Insn_Length); |
| Line_Increment := |
| int32 (Header.Line_Base) + |
| int32 (Opcode mod Header.Line_Range); |
| |
| Registers.Address := |
| Registers.Address + uint64 (Address_Increment); |
| Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment); |
| Registers.Basic_Block := 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_Insn; |
| |
| ---------------------- |
| -- Set_Load_Address -- |
| ---------------------- |
| |
| procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is |
| begin |
| C.Load_Address := Addr; |
| end Set_Load_Address; |
| |
| ------------------ |
| -- To_File_Name -- |
| ------------------ |
| |
| function To_File_Name |
| (C : in out Dwarf_Context; |
| File : uint32) return String |
| is |
| Buf : Buffer; |
| Off : Offset; |
| |
| Dir_Idx : uint32; |
| pragma Unreferenced (Dir_Idx); |
| |
| Mod_Time : uint32; |
| pragma Unreferenced (Mod_Time); |
| |
| Length : uint32; |
| pragma Unreferenced (Length); |
| |
| File_Entry_Format : Entry_Format_Array |
| renames C.Header.File_Name_Entry_Format; |
| |
| begin |
| Seek (C.Lines, C.Header.File_Names); |
| |
| -- Find the entry. Note that, up to DWARF 4, the index is 1-based |
| -- whereas, in DWARF 5, it is 0-based. |
| |
| if C.Header.Version <= 4 then |
| for J in 1 .. File loop |
| 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); |
| end loop; |
| |
| -- DWARF 5 |
| |
| else |
| for J in 0 .. File loop |
| for K in 1 .. Integer (C.Header.File_Name_Entry_Format_Count) loop |
| if File_Entry_Format (K).C_Type = DW_LNCT_path then |
| case File_Entry_Format (K).Form is |
| when DW_FORM_string => |
| Read_C_String (C.Lines, Buf); |
| |
| when DW_FORM_line_strp => |
| Read_Section_Offset (C.Lines, Off, C.Header.Is64); |
| if J = File then |
| Seek (C.Line_Str, Off); |
| Read_C_String (C.Line_Str, Buf); |
| end if; |
| |
| when others => |
| raise Dwarf_Error with "DWARF form not implemented"; |
| end case; |
| |
| else |
| Skip_Form (C.Lines, |
| File_Entry_Format (K).Form, |
| C.Header.Is64, |
| C.Header.Address_Size); |
| end if; |
| end loop; |
| end loop; |
| end if; |
| |
| 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; |
| |
| ----------------------------- |
| -- Read_Entry_Format_Array -- |
| ----------------------------- |
| |
| procedure Read_Entry_Format_Array |
| (S : in out Mapped_Stream; |
| A : out Entry_Format_Array; |
| Len : uint8) |
| is |
| C_Type, Form : uint32; |
| N : Integer; |
| |
| begin |
| N := A'First; |
| |
| for J in 1 .. Len loop |
| C_Type := Read_LEB128 (S); |
| Form := Read_LEB128 (S); |
| |
| case C_Type is |
| when DW_LNCT_path .. DW_LNCT_MD5 => |
| if N not in A'Range then |
| raise Dwarf_Error with "duplicate DWARF content type"; |
| end if; |
| |
| A (N) := (C_Type, Form); |
| N := N + 1; |
| |
| when DW_LNCT_lo_user .. DW_LNCT_hi_user => |
| null; |
| |
| when others => |
| raise Dwarf_Error with "DWARF content type not implemented"; |
| end case; |
| end loop; |
| end Read_Entry_Format_Array; |
| |
| -------------------- |
| -- Aranges_Lookup -- |
| -------------------- |
| |
| procedure Aranges_Lookup |
| (C : in out Dwarf_Context; |
| Addr : Address; |
| Info_Offset : out Offset; |
| Success : out Boolean) |
| is |
| begin |
| Info_Offset := 0; |
| 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 : Address; |
| Len : Storage_Count; |
| begin |
| Read_Aranges_Entry (C, Start, Len); |
| exit when Start = 0 and Len = 0; |
| if Addr >= Start |
| and then Addr < 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 |
| -- 7.5.5 Classes and Forms |
| |
| case Form is |
| when DW_FORM_addr => |
| Skip := Offset (Ptr_Sz); |
| when DW_FORM_block1 => |
| Skip := Offset (uint8'(Read (S))); |
| when DW_FORM_block2 => |
| Skip := Offset (uint16'(Read (S))); |
| when DW_FORM_block4 => |
| Skip := Offset (uint32'(Read (S))); |
| when DW_FORM_block | DW_FORM_exprloc => |
| Skip := Offset (uint32'(Read_LEB128 (S))); |
| when DW_FORM_addrx1 |
| | DW_FORM_data1 |
| | DW_FORM_flag |
| | DW_FORM_ref1 |
| | DW_FORM_strx1 |
| => |
| Skip := 1; |
| when DW_FORM_addrx2 |
| | DW_FORM_data2 |
| | DW_FORM_ref2 |
| | DW_FORM_strx2 |
| => |
| Skip := 2; |
| when DW_FORM_addrx3 | DW_FORM_strx3 => |
| Skip := 3; |
| when DW_FORM_addrx4 |
| | DW_FORM_data4 |
| | DW_FORM_ref4 |
| | DW_FORM_ref_sup4 |
| | DW_FORM_strx4 |
| => |
| Skip := 4; |
| when DW_FORM_data8 |
| | DW_FORM_ref8 |
| | DW_FORM_ref_sup8 |
| | DW_FORM_ref_sig8 |
| => |
| Skip := 8; |
| when DW_FORM_data16 => |
| Skip := 16; |
| when DW_FORM_sdata => |
| declare |
| Val : constant int32 := Read_LEB128 (S); |
| pragma Unreferenced (Val); |
| begin |
| return; |
| end; |
| when DW_FORM_addrx |
| | DW_FORM_loclistx |
| | DW_FORM_ref_udata |
| | DW_FORM_rnglistx |
| | DW_FORM_strx |
| | DW_FORM_udata |
| => |
| declare |
| Val : constant uint32 := Read_LEB128 (S); |
| pragma Unreferenced (Val); |
| begin |
| return; |
| end; |
| when DW_FORM_flag_present | DW_FORM_implicit_const => |
| return; |
| when DW_FORM_ref_addr |
| | DW_FORM_sec_offset |
| | DW_FORM_strp |
| | DW_FORM_line_strp |
| | DW_FORM_strp_sup |
| => |
| Skip := (if Is64 then 8 else 4); |
| when DW_FORM_string => |
| while uint8'(Read (S)) /= 0 loop |
| null; |
| end loop; |
| return; |
| when DW_FORM_indirect => |
| raise Dwarf_Error with "DW_FORM_indirect not implemented"; |
| when others => |
| raise Dwarf_Error with "DWARF form not implemented"; |
| 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 |
| Abbrev : uint32; |
| Tag : uint32; |
| Has_Child : uint8; |
| pragma Unreferenced (Tag, Has_Child); |
| |
| begin |
| Seek (C.Abbrev, Abbrev_Offset); |
| |
| -- 7.5.3 Abbreviations Tables |
| |
| loop |
| Abbrev := Read_LEB128 (C.Abbrev); |
| |
| exit when Abbrev = Abbrev_Num; |
| |
| 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); |
| Cst : int32; |
| pragma Unreferenced (Cst); |
| |
| begin |
| -- DW_FORM_implicit_const takes its value from the table |
| |
| if Form = DW_FORM_implicit_const then |
| Cst := Read_LEB128 (C.Abbrev); |
| end if; |
| |
| exit when Name = 0 and then Form = 0; |
| end; |
| end loop; |
| 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); |
| Unit_Type : uint8; |
| pragma Unreferenced (Unit_Type); |
| |
| begin |
| Line_Offset := 0; |
| Success := False; |
| |
| Seek (C.Info, Info_Offset); |
| |
| -- 7.5.1.1 Compilation Unit Header |
| |
| Read_Initial_Length (C.Info, Unit_Length, Is64); |
| |
| Version := Read (C.Info); |
| |
| if Version >= 5 then |
| Unit_Type := Read (C.Info); |
| |
| Addr_Sz := Read (C.Info); |
| if Addr_Sz /= (Address'Size / SSU) then |
| return; |
| end if; |
| |
| Read_Section_Offset (C.Info, Abbrev_Offset, Is64); |
| |
| elsif Version >= 2 then |
| Read_Section_Offset (C.Info, Abbrev_Offset, Is64); |
| |
| Addr_Sz := Read (C.Info); |
| if Addr_Sz /= (Address'Size / SSU) then |
| return; |
| end if; |
| |
| else |
| 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); |
| |
| -- Then the tag |
| |
| if Read_LEB128 (C.Abbrev) /= uint32'(DW_TAG_Compile_Unit) then |
| 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; |
| 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; |
| Info_Offset := 0; |
| |
| 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 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 := 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 := 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; |
| Val : uint64; |
| Xcode_Low : constant uint64 := uint64 (C.Low); |
| Xcode_High : constant uint64 := uint64 (C.High); |
| 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 of length 0 or located outside of the |
| -- execution code section outer boundaries. |
| |
| Sz := uint32 (Size (S)); |
| Val := Value (S); |
| |
| if Sz > 0 |
| and then Val >= Xcode_Low |
| and then Val <= Xcode_High |
| then |
| Addr := uint32 (Val - Xcode_Low); |
| |
| -- Try to filter symbols at the same address. This is a best |
| -- effort as they might not be consecutive. |
| |
| if 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; |
| 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 : 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 = Null_Address and Ar_Len = 0; |
| |
| Len := uint32 (Ar_Len); |
| Start := uint32 (Ar_Start - 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; |
| Off : Offset; |
| |
| Mod_Time : uint32; |
| pragma Unreferenced (Mod_Time); |
| |
| Length : uint32; |
| pragma Unreferenced (Length); |
| |
| Directory_Entry_Format : Entry_Format_Array |
| renames C.Header.Directory_Entry_Format; |
| |
| File_Entry_Format : Entry_Format_Array |
| renames C.Header.File_Name_Entry_Format; |
| |
| begin |
| Seek (C.Lines, C.Header.File_Names); |
| Dir_Idx := 0; |
| |
| -- Find the entry. Note that, up to DWARF 4, the index is 1-based |
| -- whereas, in DWARF 5, it is 0-based. |
| |
| if C.Header.Version <= 4 then |
| for J in 1 .. Match.File loop |
| 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); |
| end loop; |
| |
| if Dir_Idx = 0 then |
| -- No directory |
| |
| Dir_Name := null; |
| |
| else |
| Seek (C.Lines, C.Header.Directories); |
| |
| for J in 1 .. Dir_Idx loop |
| 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; |
| end loop; |
| end if; |
| |
| -- DWARF 5 |
| |
| else |
| for J in 0 .. Match.File loop |
| for K in 1 .. Integer (C.Header.File_Name_Entry_Format_Count) |
| loop |
| if File_Entry_Format (K).C_Type = DW_LNCT_path then |
| case File_Entry_Format (K).Form is |
| when DW_FORM_string => |
| File_Name := Read_C_String (C.Lines); |
| |
| when DW_FORM_line_strp => |
| Read_Section_Offset (C.Lines, Off, C.Header.Is64); |
| if J = Match.File then |
| Seek (C.Line_Str, Off); |
| File_Name := Read_C_String (C.Line_Str); |
| end if; |
| |
| when others => |
| raise Dwarf_Error with "DWARF form not implemented"; |
| end case; |
| |
| elsif File_Entry_Format (K).C_Type = DW_LNCT_directory_index |
| then |
| case File_Entry_Format (K).Form is |
| when DW_FORM_data1 => |
| Dir_Idx := uint32 (uint8'(Read (C.Lines))); |
| |
| when DW_FORM_data2 => |
| Dir_Idx := uint32 (uint16'(Read (C.Lines))); |
| |
| when DW_FORM_udata => |
| Dir_Idx := Read_LEB128 (C.Lines); |
| |
| when others => |
| raise Dwarf_Error with |
| "invalid DWARF form for DW_LNCT_directory_index"; |
| end case; |
| |
| else |
| Skip_Form (C.Lines, |
| File_Entry_Format (K).Form, |
| C.Header.Is64, |
| C.Header.Address_Size); |
| end if; |
| end loop; |
| end loop; |
| |
| Seek (C.Lines, C.Header.Directories); |
| |
| for J in 0 .. Dir_Idx loop |
| for K in 1 .. Integer (C.Header.Directory_Entry_Format_Count) |
| loop |
| if Directory_Entry_Format (K).C_Type = DW_LNCT_path then |
| case Directory_Entry_Format (K).Form is |
| when DW_FORM_string => |
| Dir_Name := Read_C_String (C.Lines); |
| |
| when DW_FORM_line_strp => |
| Read_Section_Offset (C.Lines, Off, C.Header.Is64); |
| if J = Dir_Idx then |
| Seek (C.Line_Str, Off); |
| Dir_Name := Read_C_String (C.Line_Str); |
| end if; |
| |
| when others => |
| raise Dwarf_Error with "DWARF form not implemented"; |
| end case; |
| |
| else |
| Skip_Form (C.Lines, |
| Directory_Entry_Format (K).Form, |
| C.Header.Is64, |
| C.Header.Address_Size); |
| end if; |
| end loop; |
| end loop; |
| end if; |
| |
| Line_Num := Natural (Match.Line); |
| end Set_Result; |
| |
| Addr_Int : constant uint64 := uint64 (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; |
| |
| -- Look up the symbol in the cache |
| |
| if C.Cache /= null then |
| declare |
| Addr_Off : constant uint32 := uint32 (Addr - C.Low); |
| First, Last, Mid : Natural; |
| begin |
| First := C.Cache'First; |
| Last := C.Cache'Last; |
| Mid := First; |
| |
| 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 |
| return; |
| end if; |
| end; |
| |
| -- Search for the symbol in the binary |
| |
| else |
| S := First_Symbol (C.Obj.all); |
| while S /= Null_Symbol loop |
| if Spans (S, 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_Header := 0; |
| Initialize_State_Machine (C); |
| Parse_Header (C); |
| Previous_Row.Line := 0; |
| |
| -- Advance to the first entry |
| |
| loop |
| Read_And_Execute_Insn (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_Header loop |
| Read_And_Execute_Insn (C, Done); |
| |
| if C.Registers.Is_Row then |
| if not Previous_Row.End_Sequence |
| and then Addr_Int >= Previous_Row.Address |
| and then Addr_Int < C.Registers.Address |
| then |
| Set_Result (Previous_Row); |
| return; |
| |
| elsif Addr_Int = 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 : STE.Tracebacks_Array; |
| Suppress_Hex : Boolean; |
| Symbol_Found : out Boolean; |
| Res : in out System.Bounded_Strings.Bounded_String) |
| is |
| use Ada.Characters.Handling; |
| C : Dwarf_Context := Cin; |
| |
| Addr_In_Traceback : 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_In_Traceback := STE.PC_For (Traceback (J)); |
| |
| Symbolic_Address |
| (C, |
| Addr_In_Traceback - Get_Load_Displacement (C), |
| Dir_Name, |
| File_Name, |
| Subprg_Name, |
| Line_Num); |
| |
| -- If we're not requested to suppress hex addresses, emit it now. |
| |
| if not Suppress_Hex then |
| Append_Address (Res, Addr_In_Traceback); |
| Append (Res, ' '); |
| end if; |
| |
| 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; |
| else |
| 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 Subprg_Name.Len > 0 then |
| Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); |
| |
| Append (Res, String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); |
| else |
| Append (Res, "???"); |
| end if; |
| |
| Append (Res, " at ???"); |
| end if; |
| |
| Append (Res, ASCII.LF); |
| end loop; |
| end Symbolic_Traceback; |
| |
| end System.Dwarf_Lines; |
