------------------------------------------------------------------------------ -- -- -- 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-2023, 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.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 subtype Offset is Object_Reader.Offset; 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; Addr_Size : Natural; 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; Addr_Size : out Natural; 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 Addr_Size : Natural; begin Info_Offset := 0; Seek (C.Aranges, 0); while Tell (C.Aranges) < Length (C.Aranges) loop Read_Aranges_Header (C, Info_Offset, Addr_Size, Success); exit when not Success; loop declare Start : Address; Len : Storage_Count; begin Read_Aranges_Entry (C, Addr_Size, 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); 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); 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; Addr_Size : out Natural; Success : out Boolean) is Unit_Length : Offset; Is64 : Boolean; Version : uint16; Sz : uint8; begin Success := False; Info_Offset := 0; Addr_Size := 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) Addr_Size := Natural (uint8'(Read (C.Aranges))); -- 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 * Offset (Addr_Size); 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; Addr_Size : Natural; Start : out Address; Len : out Storage_Count) is begin -- Read table if Addr_Size = 4 then declare S, L : uint32; begin S := Read (C.Aranges); L := Read (C.Aranges); Start := Address (S); Len := Storage_Count (L); end; elsif Addr_Size = 8 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; Addr_Size : Natural; 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, Addr_Size, 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, Addr_Size, Ar_Start, Ar_Len); exit when Ar_Start = Null_Address and Ar_Len = 0; Len := uint32 (Ar_Len); Start := uint32 (Address'(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 (Address'(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;