1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S Y S T E M . D W A R F _ L I N E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2009-2020, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Ada.Characters.Handling; 33with Ada.Containers.Generic_Array_Sort; 34with Ada.Unchecked_Deallocation; 35 36with Interfaces; use Interfaces; 37 38with System; use System; 39with System.Address_Image; 40with System.Bounded_Strings; use System.Bounded_Strings; 41with System.IO; use System.IO; 42with System.Mmap; use System.Mmap; 43with System.Object_Reader; use System.Object_Reader; 44with System.Storage_Elements; use System.Storage_Elements; 45 46package body System.Dwarf_Lines is 47 48 SSU : constant := System.Storage_Unit; 49 50 function Get_Load_Displacement (C : Dwarf_Context) return Storage_Offset; 51 -- Return the displacement between the load address present in the binary 52 -- and the run-time address at which it is loaded (i.e. non-zero for PIE). 53 54 function String_Length (Str : Str_Access) return Natural; 55 -- Return the length of the C string Str 56 57 --------------------------------- 58 -- DWARF Parser Implementation -- 59 --------------------------------- 60 61 procedure Read_Initial_Length 62 (S : in out Mapped_Stream; 63 Len : out Offset; 64 Is64 : out Boolean); 65 -- Read initial length as specified by 7.2.2 66 67 procedure Read_Section_Offset 68 (S : in out Mapped_Stream; 69 Len : out Offset; 70 Is64 : Boolean); 71 -- Read a section offset, as specified by 7.4 72 73 procedure Read_Entry_Format_Array 74 (S : in out Mapped_Stream; 75 A : out Entry_Format_Array; 76 Len : uint8); 77 -- Read an entry format array, as specified by 6.2.4.1 78 79 procedure Read_Aranges_Entry 80 (C : in out Dwarf_Context; 81 Start : out Address; 82 Len : out Storage_Count); 83 -- Read a single .debug_aranges pair 84 85 procedure Read_Aranges_Header 86 (C : in out Dwarf_Context; 87 Info_Offset : out Offset; 88 Success : out Boolean); 89 -- Read .debug_aranges header 90 91 procedure Aranges_Lookup 92 (C : in out Dwarf_Context; 93 Addr : Address; 94 Info_Offset : out Offset; 95 Success : out Boolean); 96 -- Search for Addr in .debug_aranges and return offset Info_Offset in 97 -- .debug_info. 98 99 procedure Skip_Form 100 (S : in out Mapped_Stream; 101 Form : uint32; 102 Is64 : Boolean; 103 Ptr_Sz : uint8); 104 -- Advance offset in S for Form. 105 106 procedure Seek_Abbrev 107 (C : in out Dwarf_Context; 108 Abbrev_Offset : Offset; 109 Abbrev_Num : uint32); 110 -- Seek to abbrev Abbrev_Num (starting from Abbrev_Offset) 111 112 procedure Debug_Info_Lookup 113 (C : in out Dwarf_Context; 114 Info_Offset : Offset; 115 Line_Offset : out Offset; 116 Success : out Boolean); 117 -- Search for stmt_list tag in Info_Offset and set Line_Offset to the 118 -- offset in .debug_lines. Only look at the first DIE, which should be 119 -- a compilation unit. 120 121 procedure Initialize_Pass (C : in out Dwarf_Context); 122 -- Seek to the first byte of the first header and prepare to make a pass 123 -- over the line number entries. 124 125 procedure Initialize_State_Machine (C : in out Dwarf_Context); 126 -- Set all state machine registers to their specified initial values 127 128 procedure Parse_Header (C : in out Dwarf_Context); 129 -- Decode a DWARF statement program header 130 131 procedure Read_And_Execute_Insn 132 (C : in out Dwarf_Context; 133 Done : out Boolean); 134 -- Read an execute a statement program instruction 135 136 function To_File_Name 137 (C : in out Dwarf_Context; 138 File : uint32) return String; 139 -- Extract a file name from the header 140 141 type Callback is access procedure (C : in out Dwarf_Context); 142 procedure For_Each_Row (C : in out Dwarf_Context; F : Callback); 143 -- Traverse each .debug_line entry with a callback 144 145 procedure Dump_Row (C : in out Dwarf_Context); 146 -- Dump a single row 147 148 function "<" (Left, Right : Search_Entry) return Boolean; 149 -- For sorting Search_Entry 150 151 procedure Sort_Search_Array is new Ada.Containers.Generic_Array_Sort 152 (Index_Type => Natural, 153 Element_Type => Search_Entry, 154 Array_Type => Search_Array); 155 156 procedure Symbolic_Address 157 (C : in out Dwarf_Context; 158 Addr : Address; 159 Dir_Name : out Str_Access; 160 File_Name : out Str_Access; 161 Subprg_Name : out String_Ptr_Len; 162 Line_Num : out Natural); 163 -- Symbolize one address 164 165 ----------------------- 166 -- DWARF constants -- 167 ----------------------- 168 169 -- 3.1.1 Full and Partial Compilation Unit Entries 170 171 DW_TAG_Compile_Unit : constant := 16#11#; 172 173 DW_AT_Stmt_List : constant := 16#10#; 174 175 -- 6.2.4.1 Standard Content Descriptions (DWARF 5) 176 177 DW_LNCT_path : constant := 1; 178 DW_LNCT_directory_index : constant := 2; 179 -- DW_LNCT_timestamp : constant := 3; 180 -- DW_LNCT_size : constant := 4; 181 DW_LNCT_MD5 : constant := 5; 182 DW_LNCT_lo_user : constant := 16#2000#; 183 DW_LNCT_hi_user : constant := 16#3fff#; 184 185 -- 6.2.5.2 Standard Opcodes 186 187 DW_LNS_extended_op : constant := 0; 188 DW_LNS_copy : constant := 1; 189 DW_LNS_advance_pc : constant := 2; 190 DW_LNS_advance_line : constant := 3; 191 DW_LNS_set_file : constant := 4; 192 DW_LNS_set_column : constant := 5; 193 DW_LNS_negate_stmt : constant := 6; 194 DW_LNS_set_basic_block : constant := 7; 195 DW_LNS_const_add_pc : constant := 8; 196 DW_LNS_fixed_advance_pc : constant := 9; 197 DW_LNS_set_prologue_end : constant := 10; 198 DW_LNS_set_epilogue_begin : constant := 11; 199 DW_LNS_set_isa : constant := 12; 200 201 -- 6.2.5.3 Extended Opcodes 202 203 DW_LNE_end_sequence : constant := 1; 204 DW_LNE_set_address : constant := 2; 205 DW_LNE_define_file : constant := 3; 206 DW_LNE_set_discriminator : constant := 4; 207 208 -- 7.5.5 Classes and Forms 209 210 DW_FORM_addr : constant := 16#01#; 211 DW_FORM_block2 : constant := 16#03#; 212 DW_FORM_block4 : constant := 16#04#; 213 DW_FORM_data2 : constant := 16#05#; 214 DW_FORM_data4 : constant := 16#06#; 215 DW_FORM_data8 : constant := 16#07#; 216 DW_FORM_string : constant := 16#08#; 217 DW_FORM_block : constant := 16#09#; 218 DW_FORM_block1 : constant := 16#0a#; 219 DW_FORM_data1 : constant := 16#0b#; 220 DW_FORM_flag : constant := 16#0c#; 221 DW_FORM_sdata : constant := 16#0d#; 222 DW_FORM_strp : constant := 16#0e#; 223 DW_FORM_udata : constant := 16#0f#; 224 DW_FORM_ref_addr : constant := 16#10#; 225 DW_FORM_ref1 : constant := 16#11#; 226 DW_FORM_ref2 : constant := 16#12#; 227 DW_FORM_ref4 : constant := 16#13#; 228 DW_FORM_ref8 : constant := 16#14#; 229 DW_FORM_ref_udata : constant := 16#15#; 230 DW_FORM_indirect : constant := 16#16#; 231 DW_FORM_sec_offset : constant := 16#17#; 232 DW_FORM_exprloc : constant := 16#18#; 233 DW_FORM_flag_present : constant := 16#19#; 234 DW_FORM_strx : constant := 16#1a#; 235 DW_FORM_addrx : constant := 16#1b#; 236 DW_FORM_ref_sup4 : constant := 16#1c#; 237 DW_FORM_strp_sup : constant := 16#1d#; 238 DW_FORM_data16 : constant := 16#1e#; 239 DW_FORM_line_strp : constant := 16#1f#; 240 DW_FORM_ref_sig8 : constant := 16#20#; 241 DW_FORM_implicit_const : constant := 16#21#; 242 DW_FORM_loclistx : constant := 16#22#; 243 DW_FORM_rnglistx : constant := 16#23#; 244 DW_FORM_ref_sup8 : constant := 16#24#; 245 DW_FORM_strx1 : constant := 16#25#; 246 DW_FORM_strx2 : constant := 16#26#; 247 DW_FORM_strx3 : constant := 16#27#; 248 DW_FORM_strx4 : constant := 16#28#; 249 DW_FORM_addrx1 : constant := 16#29#; 250 DW_FORM_addrx2 : constant := 16#2a#; 251 DW_FORM_addrx3 : constant := 16#2b#; 252 DW_FORM_addrx4 : constant := 16#2c#; 253 254 --------- 255 -- "<" -- 256 --------- 257 258 function "<" (Left, Right : Search_Entry) return Boolean is 259 begin 260 return Left.First < Right.First; 261 end "<"; 262 263 ----------- 264 -- Close -- 265 ----------- 266 267 procedure Close (C : in out Dwarf_Context) is 268 procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation 269 (Object_File, 270 Object_File_Access); 271 procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation 272 (Search_Array, 273 Search_Array_Access); 274 275 begin 276 if C.Has_Debug then 277 Close (C.Lines); 278 Close (C.Abbrev); 279 Close (C.Info); 280 Close (C.Aranges); 281 end if; 282 283 Close (C.Obj.all); 284 Unchecked_Deallocation (C.Obj); 285 286 Unchecked_Deallocation (C.Cache); 287 end Close; 288 289 ---------- 290 -- Dump -- 291 ---------- 292 293 procedure Dump (C : in out Dwarf_Context) is 294 begin 295 For_Each_Row (C, Dump_Row'Access); 296 end Dump; 297 298 -------------- 299 -- Dump_Row -- 300 -------------- 301 302 procedure Dump_Row (C : in out Dwarf_Context) is 303 PC : constant Integer_Address := Integer_Address (C.Registers.Address); 304 Off : Offset; 305 306 begin 307 Tell (C.Lines, Off); 308 309 Put (System.Address_Image (To_Address (PC))); 310 Put (" "); 311 Put (To_File_Name (C, C.Registers.File)); 312 Put (":"); 313 314 declare 315 Image : constant String := uint32'Image (C.Registers.Line); 316 begin 317 Put_Line (Image (2 .. Image'Last)); 318 end; 319 320 Seek (C.Lines, Off); 321 end Dump_Row; 322 323 procedure Dump_Cache (C : Dwarf_Context) is 324 Cache : constant Search_Array_Access := C.Cache; 325 S : Object_Symbol; 326 Name : String_Ptr_Len; 327 328 begin 329 if Cache = null then 330 Put_Line ("No cache"); 331 return; 332 end if; 333 334 for I in Cache'Range loop 335 declare 336 E : Search_Entry renames Cache (I); 337 Base_Address : constant System.Address := 338 To_Address (Integer_Address (C.Low + Storage_Count (E.First))); 339 begin 340 Put (System.Address_Image (Base_Address)); 341 Put (" - "); 342 Put (System.Address_Image (Base_Address + Storage_Count (E.Size))); 343 Put (" l@"); 344 Put (System.Address_Image (To_Address (Integer_Address (E.Line)))); 345 Put (": "); 346 S := Read_Symbol (C.Obj.all, Offset (E.Sym)); 347 Name := Object_Reader.Name (C.Obj.all, S); 348 Put (String (Name.Ptr (1 .. Name.Len))); 349 New_Line; 350 end; 351 end loop; 352 end Dump_Cache; 353 354 ------------------ 355 -- For_Each_Row -- 356 ------------------ 357 358 procedure For_Each_Row (C : in out Dwarf_Context; F : Callback) is 359 Done : Boolean; 360 361 begin 362 Initialize_Pass (C); 363 364 loop 365 Read_And_Execute_Insn (C, Done); 366 367 if C.Registers.Is_Row then 368 F.all (C); 369 end if; 370 371 exit when Done; 372 end loop; 373 end For_Each_Row; 374 375 --------------------------- 376 -- Get_Load_Displacement -- 377 --------------------------- 378 379 function Get_Load_Displacement (C : Dwarf_Context) return Storage_Offset is 380 begin 381 if C.Load_Address /= Null_Address then 382 return C.Load_Address - Address (Get_Load_Address (C.Obj.all)); 383 else 384 return 0; 385 end if; 386 end Get_Load_Displacement; 387 388 --------------------- 389 -- Initialize_Pass -- 390 --------------------- 391 392 procedure Initialize_Pass (C : in out Dwarf_Context) is 393 begin 394 Seek (C.Lines, 0); 395 C.Next_Header := 0; 396 Initialize_State_Machine (C); 397 end Initialize_Pass; 398 399 ------------------------------ 400 -- Initialize_State_Machine -- 401 ------------------------------ 402 403 procedure Initialize_State_Machine (C : in out Dwarf_Context) is 404 begin 405 -- Table 6.4: Line number program initial state 406 407 C.Registers := 408 (Address => 0, 409 File => 1, 410 Line => 1, 411 Column => 0, 412 Is_Stmt => C.Header.Default_Is_Stmt /= 0, 413 Basic_Block => False, 414 End_Sequence => False, 415 Is_Row => False); 416 end Initialize_State_Machine; 417 418 --------------- 419 -- Is_Inside -- 420 --------------- 421 422 function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is 423 Disp : constant Storage_Offset := Get_Load_Displacement (C); 424 425 begin 426 return Addr >= C.Low + Disp and then Addr <= C.High + Disp; 427 end Is_Inside; 428 429 ----------------- 430 -- Low_Address -- 431 ----------------- 432 433 function Low_Address (C : Dwarf_Context) return Address is 434 begin 435 return C.Low + Get_Load_Displacement (C); 436 end Low_Address; 437 438 ---------- 439 -- Open -- 440 ---------- 441 442 procedure Open 443 (File_Name : String; 444 C : out Dwarf_Context; 445 Success : out Boolean) 446 is 447 Abbrev, Aranges, Lines, Info, Line_Str : Object_Section; 448 Hi, Lo : uint64; 449 450 begin 451 -- Not a success by default 452 453 Success := False; 454 455 -- Open file with In_Exception set so we can control the failure mode 456 457 C.Obj := Open (File_Name, In_Exception => True); 458 459 if C.Obj = null then 460 if C.In_Exception then 461 return; 462 else 463 raise Dwarf_Error with "could not open file"; 464 end if; 465 end if; 466 467 Success := True; 468 469 -- Get address bounds for executable code. Note that such code 470 -- might come from multiple sections. 471 472 Get_Xcode_Bounds (C.Obj.all, Lo, Hi); 473 C.Low := Address (Lo); 474 C.High := Address (Hi); 475 476 -- Create a stream for debug sections 477 478 if Format (C.Obj.all) = XCOFF32 then 479 Abbrev := Get_Section (C.Obj.all, ".dwabrev"); 480 Aranges := Get_Section (C.Obj.all, ".dwarnge"); 481 Info := Get_Section (C.Obj.all, ".dwinfo"); 482 Lines := Get_Section (C.Obj.all, ".dwline"); 483 Line_Str := Get_Section (C.Obj.all, ".dwlistr"); 484 else 485 Abbrev := Get_Section (C.Obj.all, ".debug_abbrev"); 486 Aranges := Get_Section (C.Obj.all, ".debug_aranges"); 487 Info := Get_Section (C.Obj.all, ".debug_info"); 488 Lines := Get_Section (C.Obj.all, ".debug_line"); 489 Line_Str := Get_Section (C.Obj.all, ".debug_line_str"); 490 end if; 491 492 if Abbrev = Null_Section 493 or else Aranges = Null_Section 494 or else Info = Null_Section 495 or else Lines = Null_Section 496 then 497 pragma Annotate 498 (CodePeer, False_Positive, 499 "test always true", "codepeer got confused"); 500 501 C.Has_Debug := False; 502 return; 503 end if; 504 505 C.Abbrev := Create_Stream (C.Obj.all, Abbrev); 506 C.Aranges := Create_Stream (C.Obj.all, Aranges); 507 C.Info := Create_Stream (C.Obj.all, Info); 508 C.Lines := Create_Stream (C.Obj.all, Lines); 509 510 -- The .debug_line_str section may be available in DWARF 5 511 512 if Line_Str /= Null_Section then 513 C.Line_Str := Create_Stream (C.Obj.all, Line_Str); 514 end if; 515 516 -- All operations are successful, context is valid 517 518 C.Has_Debug := True; 519 end Open; 520 521 ------------------ 522 -- Parse_Header -- 523 ------------------ 524 525 procedure Parse_Header (C : in out Dwarf_Context) is 526 Header : Line_Info_Header renames C.Header; 527 528 Char : uint8; 529 Prev : uint8; 530 -- The most recently read character and the one preceding it 531 532 Dummy : uint32; 533 -- Destination for reads we don't care about 534 535 Buf : Buffer; 536 Off : Offset; 537 538 First_Byte_Of_Header : Offset; 539 Last_Byte_Of_Header : Offset; 540 541 Standard_Opcode_Lengths : Opcode_Length_Array; 542 pragma Unreferenced (Standard_Opcode_Lengths); 543 544 begin 545 Tell (C.Lines, First_Byte_Of_Header); 546 547 Read_Initial_Length (C.Lines, Header.Unit_Length, Header.Is64); 548 549 Tell (C.Lines, Off); 550 C.Next_Header := Off + Header.Unit_Length; 551 552 Header.Version := Read (C.Lines); 553 554 if Header.Version >= 5 then 555 Header.Address_Size := Read (C.Lines); 556 Header.Segment_Selector_Size := Read (C.Lines); 557 else 558 Header.Address_Size := 0; 559 Header.Segment_Selector_Size := 0; 560 end if; 561 562 Header.Header_Length := Read (C.Lines); 563 Tell (C.Lines, Last_Byte_Of_Header); 564 Last_Byte_Of_Header := 565 Last_Byte_Of_Header + Offset (Header.Header_Length) - 1; 566 567 Header.Minimum_Insn_Length := Read (C.Lines); 568 569 if Header.Version >= 4 then 570 Header.Maximum_Op_Per_Insn := Read (C.Lines); 571 else 572 Header.Maximum_Op_Per_Insn := 0; 573 end if; 574 575 Header.Default_Is_Stmt := Read (C.Lines); 576 Header.Line_Base := Read (C.Lines); 577 Header.Line_Range := Read (C.Lines); 578 Header.Opcode_Base := Read (C.Lines); 579 580 -- Standard_Opcode_Lengths is an array of Opcode_Base bytes specifying 581 -- the number of LEB128 operands for each of the standard opcodes. 582 583 for J in 1 .. Integer (Header.Opcode_Base - 1) loop 584 Standard_Opcode_Lengths (J) := Read (C.Lines); 585 end loop; 586 587 -- The Directories table follows. Up to DWARF 4, this is a list of null 588 -- terminated strings terminated by a null byte. In DWARF 5, this is a 589 -- sequence of Directories_Count entries which are encoded as described 590 -- by the Directory_Entry_Format field. We store its offset for later. 591 592 if Header.Version <= 4 then 593 Tell (C.Lines, Header.Directories); 594 Char := Read (C.Lines); 595 596 if Char /= 0 then 597 loop 598 Prev := Char; 599 Char := Read (C.Lines); 600 exit when Char = 0 and Prev = 0; 601 end loop; 602 end if; 603 604 else 605 Header.Directory_Entry_Format_Count := Read (C.Lines); 606 Read_Entry_Format_Array (C.Lines, 607 Header.Directory_Entry_Format, 608 Header.Directory_Entry_Format_Count); 609 610 Header.Directories_Count := Read_LEB128 (C.Lines); 611 Tell (C.Lines, Header.Directories); 612 for J in 1 .. Header.Directories_Count loop 613 for K in 1 .. Integer (Header.Directory_Entry_Format_Count) loop 614 Skip_Form (C.Lines, 615 Header.Directory_Entry_Format (K).Form, 616 Header.Is64, 617 Header.Address_Size); 618 end loop; 619 end loop; 620 end if; 621 622 -- The File_Names table is next. Up to DWARF 4, this is a list of record 623 -- containing a null terminated string for the file name, an unsigned 624 -- LEB128 directory index in the Directories table, an unsigned LEB128 625 -- modification time, and an unsigned LEB128 for the file length; the 626 -- table is terminated by a null byte. In DWARF 5, this is a sequence 627 -- of File_Names_Count entries which are encoded as described by the 628 -- File_Name_Entry_Format field. We store its offset for later decoding. 629 630 if Header.Version <= 4 then 631 Tell (C.Lines, Header.File_Names); 632 633 -- Read the file names 634 635 loop 636 Read_C_String (C.Lines, Buf); 637 exit when Buf (0) = 0; 638 Dummy := Read_LEB128 (C.Lines); -- Skip the directory index. 639 Dummy := Read_LEB128 (C.Lines); -- Skip the modification time. 640 Dummy := Read_LEB128 (C.Lines); -- Skip the file length. 641 end loop; 642 643 else 644 Header.File_Name_Entry_Format_Count := Read (C.Lines); 645 Read_Entry_Format_Array (C.Lines, 646 Header.File_Name_Entry_Format, 647 Header.File_Name_Entry_Format_Count); 648 649 Header.File_Names_Count := Read_LEB128 (C.Lines); 650 Tell (C.Lines, Header.File_Names); 651 for J in 1 .. Header.File_Names_Count loop 652 for K in 1 .. Integer (Header.File_Name_Entry_Format_Count) loop 653 Skip_Form (C.Lines, 654 Header.File_Name_Entry_Format (K).Form, 655 Header.Is64, 656 Header.Address_Size); 657 end loop; 658 end loop; 659 end if; 660 661 -- Check we're where we think we are. This sanity check ensures we think 662 -- the header ends where the header says it does. It we aren't, then we 663 -- have probably gotten out of sync somewhere. 664 665 Tell (C.Lines, Off); 666 667 if Header.Unit_Length /= 0 668 and then Off /= Last_Byte_Of_Header + 1 669 then 670 raise Dwarf_Error with "parse error reading DWARF information"; 671 end if; 672 end Parse_Header; 673 674 --------------------------- 675 -- Read_And_Execute_Insn -- 676 --------------------------- 677 678 procedure Read_And_Execute_Insn 679 (C : in out Dwarf_Context; 680 Done : out Boolean) 681 is 682 Opcode : uint8; 683 Extended_Opcode : uint8; 684 uint32_Operand : uint32; 685 int32_Operand : int32; 686 uint16_Operand : uint16; 687 Off : Offset; 688 689 Extended_Length : uint32; 690 pragma Unreferenced (Extended_Length); 691 692 Obj : Object_File renames C.Obj.all; 693 Registers : Line_Info_Registers renames C.Registers; 694 Header : Line_Info_Header renames C.Header; 695 696 begin 697 Done := False; 698 Registers.Is_Row := False; 699 700 if Registers.End_Sequence then 701 Initialize_State_Machine (C); 702 end if; 703 704 -- If we have reached the next header, read it. Beware of possibly empty 705 -- blocks. 706 707 -- When testing for the end of section, beware of possible zero padding 708 -- at the end. Bail out as soon as there's not even room for at least a 709 -- DW_LNE_end_sequence, 3 bytes from Off to Off+2. This resolves to 710 -- Off+2 > Last_Offset_Within_Section, that is Off+2 > Section_Length-1, 711 -- or Off+3 > Section_Length. 712 713 Tell (C.Lines, Off); 714 while Off = C.Next_Header loop 715 Initialize_State_Machine (C); 716 Parse_Header (C); 717 Tell (C.Lines, Off); 718 exit when Off + 3 > Length (C.Lines); 719 end loop; 720 721 -- Test whether we're done 722 723 Tell (C.Lines, Off); 724 725 -- We are finished when we either reach the end of the section, or we 726 -- have reached zero padding at the end of the section. 727 728 if Header.Unit_Length = 0 or else Off + 3 > Length (C.Lines) then 729 Done := True; 730 return; 731 end if; 732 733 -- Read and interpret an instruction 734 735 Opcode := Read (C.Lines); 736 737 -- Extended opcodes 738 739 if Opcode = DW_LNS_extended_op then 740 Extended_Length := Read_LEB128 (C.Lines); 741 Extended_Opcode := Read (C.Lines); 742 743 case Extended_Opcode is 744 when DW_LNE_end_sequence => 745 746 -- Mark the end of a sequence of source locations 747 748 Registers.End_Sequence := True; 749 Registers.Is_Row := True; 750 751 when DW_LNE_set_address => 752 753 -- Set the program counter to a word 754 755 Registers.Address := Read_Address (Obj, C.Lines); 756 757 when DW_LNE_define_file => 758 759 -- Not implemented 760 761 raise Dwarf_Error with "DWARF operator not implemented"; 762 763 when DW_LNE_set_discriminator => 764 765 -- Ignored 766 767 int32_Operand := Read_LEB128 (C.Lines); 768 769 when others => 770 771 -- Fail on an unrecognized opcode 772 773 raise Dwarf_Error with "DWARF operator not implemented"; 774 end case; 775 776 -- Standard opcodes 777 778 elsif Opcode < Header.Opcode_Base then 779 case Opcode is 780 781 -- Append a row to the line info matrix 782 783 when DW_LNS_copy => 784 Registers.Basic_Block := False; 785 Registers.Is_Row := True; 786 787 -- Add an unsigned word to the program counter 788 789 when DW_LNS_advance_pc => 790 uint32_Operand := Read_LEB128 (C.Lines); 791 Registers.Address := 792 Registers.Address + 793 uint64 (uint32_Operand * uint32 (Header.Minimum_Insn_Length)); 794 795 -- Add a signed word to the current source line 796 797 when DW_LNS_advance_line => 798 int32_Operand := Read_LEB128 (C.Lines); 799 Registers.Line := 800 uint32 (int32 (Registers.Line) + int32_Operand); 801 802 -- Set the current source file 803 804 when DW_LNS_set_file => 805 uint32_Operand := Read_LEB128 (C.Lines); 806 Registers.File := uint32_Operand; 807 808 -- Set the current source column 809 810 when DW_LNS_set_column => 811 uint32_Operand := Read_LEB128 (C.Lines); 812 Registers.Column := uint32_Operand; 813 814 -- Toggle the "is statement" flag. GCC doesn't seem to set this??? 815 816 when DW_LNS_negate_stmt => 817 Registers.Is_Stmt := not Registers.Is_Stmt; 818 819 -- Mark the beginning of a basic block 820 821 when DW_LNS_set_basic_block => 822 Registers.Basic_Block := True; 823 824 -- Advance the program counter as by the special opcode 255 825 826 when DW_LNS_const_add_pc => 827 Registers.Address := 828 Registers.Address + 829 uint64 830 (((255 - Header.Opcode_Base) / Header.Line_Range) * 831 Header.Minimum_Insn_Length); 832 833 -- Advance the program counter by a constant 834 835 when DW_LNS_fixed_advance_pc => 836 uint16_Operand := Read (C.Lines); 837 Registers.Address := 838 Registers.Address + uint64 (uint16_Operand); 839 840 -- The following are not implemented and ignored 841 842 when DW_LNS_set_prologue_end => 843 null; 844 845 when DW_LNS_set_epilogue_begin => 846 null; 847 848 when DW_LNS_set_isa => 849 null; 850 851 -- Anything else is an error 852 853 when others => 854 raise Dwarf_Error with "DWARF operator not implemented"; 855 end case; 856 857 -- Decode a special opcode. This is a line and address increment encoded 858 -- in a single byte 'special opcode' as described in 6.2.5.1. 859 860 else 861 declare 862 Address_Increment : int32; 863 Line_Increment : int32; 864 865 begin 866 Opcode := Opcode - Header.Opcode_Base; 867 868 -- The adjusted opcode is a uint8 encoding an address increment 869 -- and a signed line increment. The upperbound is allowed to be 870 -- greater than int8'last so we decode using int32 directly to 871 -- prevent overflows. 872 873 Address_Increment := 874 int32 (Opcode / Header.Line_Range) * 875 int32 (Header.Minimum_Insn_Length); 876 Line_Increment := 877 int32 (Header.Line_Base) + 878 int32 (Opcode mod Header.Line_Range); 879 880 Registers.Address := 881 Registers.Address + uint64 (Address_Increment); 882 Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment); 883 Registers.Basic_Block := False; 884 Registers.Is_Row := True; 885 end; 886 end if; 887 888 exception 889 when Dwarf_Error => 890 891 -- In case of errors during parse, just stop reading 892 893 Registers.Is_Row := False; 894 Done := True; 895 end Read_And_Execute_Insn; 896 897 ---------------------- 898 -- Set_Load_Address -- 899 ---------------------- 900 901 procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is 902 begin 903 C.Load_Address := Addr; 904 end Set_Load_Address; 905 906 ------------------ 907 -- To_File_Name -- 908 ------------------ 909 910 function To_File_Name 911 (C : in out Dwarf_Context; 912 File : uint32) return String 913 is 914 Buf : Buffer; 915 Off : Offset; 916 917 Dir_Idx : uint32; 918 pragma Unreferenced (Dir_Idx); 919 920 Mod_Time : uint32; 921 pragma Unreferenced (Mod_Time); 922 923 Length : uint32; 924 pragma Unreferenced (Length); 925 926 File_Entry_Format : Entry_Format_Array 927 renames C.Header.File_Name_Entry_Format; 928 929 begin 930 Seek (C.Lines, C.Header.File_Names); 931 932 -- Find the entry. Note that, up to DWARF 4, the index is 1-based 933 -- whereas, in DWARF 5, it is 0-based. 934 935 if C.Header.Version <= 4 then 936 for J in 1 .. File loop 937 Read_C_String (C.Lines, Buf); 938 939 if Buf (Buf'First) = 0 then 940 return "???"; 941 end if; 942 943 Dir_Idx := Read_LEB128 (C.Lines); 944 Mod_Time := Read_LEB128 (C.Lines); 945 Length := Read_LEB128 (C.Lines); 946 end loop; 947 948 -- DWARF 5 949 950 else 951 for J in 0 .. File loop 952 for K in 1 .. Integer (C.Header.File_Name_Entry_Format_Count) loop 953 if File_Entry_Format (K).C_Type = DW_LNCT_path then 954 case File_Entry_Format (K).Form is 955 when DW_FORM_string => 956 Read_C_String (C.Lines, Buf); 957 958 when DW_FORM_line_strp => 959 Read_Section_Offset (C.Lines, Off, C.Header.Is64); 960 if J = File then 961 Seek (C.Line_Str, Off); 962 Read_C_String (C.Line_Str, Buf); 963 end if; 964 965 when others => 966 raise Dwarf_Error with "DWARF form not implemented"; 967 end case; 968 969 else 970 Skip_Form (C.Lines, 971 File_Entry_Format (K).Form, 972 C.Header.Is64, 973 C.Header.Address_Size); 974 end if; 975 end loop; 976 end loop; 977 end if; 978 979 return To_String (Buf); 980 end To_File_Name; 981 982 ------------------------- 983 -- Read_Initial_Length -- 984 ------------------------- 985 986 procedure Read_Initial_Length 987 (S : in out Mapped_Stream; 988 Len : out Offset; 989 Is64 : out Boolean) 990 is 991 Len32 : uint32; 992 Len64 : uint64; 993 994 begin 995 Len32 := Read (S); 996 if Len32 < 16#ffff_fff0# then 997 Is64 := False; 998 Len := Offset (Len32); 999 elsif Len32 < 16#ffff_ffff# then 1000 -- Invalid length 1001 raise Constraint_Error; 1002 else 1003 Is64 := True; 1004 Len64 := Read (S); 1005 Len := Offset (Len64); 1006 end if; 1007 end Read_Initial_Length; 1008 1009 ------------------------- 1010 -- Read_Section_Offset -- 1011 ------------------------- 1012 1013 procedure Read_Section_Offset 1014 (S : in out Mapped_Stream; 1015 Len : out Offset; 1016 Is64 : Boolean) 1017 is 1018 begin 1019 if Is64 then 1020 Len := Offset (uint64'(Read (S))); 1021 else 1022 Len := Offset (uint32'(Read (S))); 1023 end if; 1024 end Read_Section_Offset; 1025 1026 ----------------------------- 1027 -- Read_Entry_Format_Array -- 1028 ----------------------------- 1029 1030 procedure Read_Entry_Format_Array 1031 (S : in out Mapped_Stream; 1032 A : out Entry_Format_Array; 1033 Len : uint8) 1034 is 1035 C_Type, Form : uint32; 1036 N : Integer; 1037 1038 begin 1039 N := A'First; 1040 1041 for J in 1 .. Len loop 1042 C_Type := Read_LEB128 (S); 1043 Form := Read_LEB128 (S); 1044 1045 case C_Type is 1046 when DW_LNCT_path .. DW_LNCT_MD5 => 1047 if N not in A'Range then 1048 raise Dwarf_Error with "duplicate DWARF content type"; 1049 end if; 1050 1051 A (N) := (C_Type, Form); 1052 N := N + 1; 1053 1054 when DW_LNCT_lo_user .. DW_LNCT_hi_user => 1055 null; 1056 1057 when others => 1058 raise Dwarf_Error with "DWARF content type not implemented"; 1059 end case; 1060 end loop; 1061 end Read_Entry_Format_Array; 1062 1063 -------------------- 1064 -- Aranges_Lookup -- 1065 -------------------- 1066 1067 procedure Aranges_Lookup 1068 (C : in out Dwarf_Context; 1069 Addr : Address; 1070 Info_Offset : out Offset; 1071 Success : out Boolean) 1072 is 1073 begin 1074 Info_Offset := 0; 1075 Seek (C.Aranges, 0); 1076 1077 while Tell (C.Aranges) < Length (C.Aranges) loop 1078 Read_Aranges_Header (C, Info_Offset, Success); 1079 exit when not Success; 1080 1081 loop 1082 declare 1083 Start : Address; 1084 Len : Storage_Count; 1085 begin 1086 Read_Aranges_Entry (C, Start, Len); 1087 exit when Start = 0 and Len = 0; 1088 if Addr >= Start 1089 and then Addr < Start + Len 1090 then 1091 Success := True; 1092 return; 1093 end if; 1094 end; 1095 end loop; 1096 end loop; 1097 1098 Success := False; 1099 end Aranges_Lookup; 1100 1101 --------------- 1102 -- Skip_Form -- 1103 --------------- 1104 1105 procedure Skip_Form 1106 (S : in out Mapped_Stream; 1107 Form : uint32; 1108 Is64 : Boolean; 1109 Ptr_Sz : uint8) 1110 is 1111 Skip : Offset; 1112 1113 begin 1114 -- 7.5.5 Classes and Forms 1115 1116 case Form is 1117 when DW_FORM_addr => 1118 Skip := Offset (Ptr_Sz); 1119 when DW_FORM_block1 => 1120 Skip := Offset (uint8'(Read (S))); 1121 when DW_FORM_block2 => 1122 Skip := Offset (uint16'(Read (S))); 1123 when DW_FORM_block4 => 1124 Skip := Offset (uint32'(Read (S))); 1125 when DW_FORM_block | DW_FORM_exprloc => 1126 Skip := Offset (uint32'(Read_LEB128 (S))); 1127 when DW_FORM_addrx1 1128 | DW_FORM_data1 1129 | DW_FORM_flag 1130 | DW_FORM_ref1 1131 | DW_FORM_strx1 1132 => 1133 Skip := 1; 1134 when DW_FORM_addrx2 1135 | DW_FORM_data2 1136 | DW_FORM_ref2 1137 | DW_FORM_strx2 1138 => 1139 Skip := 2; 1140 when DW_FORM_addrx3 | DW_FORM_strx3 => 1141 Skip := 3; 1142 when DW_FORM_addrx4 1143 | DW_FORM_data4 1144 | DW_FORM_ref4 1145 | DW_FORM_ref_sup4 1146 | DW_FORM_strx4 1147 => 1148 Skip := 4; 1149 when DW_FORM_data8 1150 | DW_FORM_ref8 1151 | DW_FORM_ref_sup8 1152 | DW_FORM_ref_sig8 1153 => 1154 Skip := 8; 1155 when DW_FORM_data16 => 1156 Skip := 16; 1157 when DW_FORM_sdata => 1158 declare 1159 Val : constant int32 := Read_LEB128 (S); 1160 pragma Unreferenced (Val); 1161 begin 1162 return; 1163 end; 1164 when DW_FORM_addrx 1165 | DW_FORM_loclistx 1166 | DW_FORM_ref_udata 1167 | DW_FORM_rnglistx 1168 | DW_FORM_strx 1169 | DW_FORM_udata 1170 => 1171 declare 1172 Val : constant uint32 := Read_LEB128 (S); 1173 pragma Unreferenced (Val); 1174 begin 1175 return; 1176 end; 1177 when DW_FORM_flag_present | DW_FORM_implicit_const => 1178 return; 1179 when DW_FORM_ref_addr 1180 | DW_FORM_sec_offset 1181 | DW_FORM_strp 1182 | DW_FORM_line_strp 1183 | DW_FORM_strp_sup 1184 => 1185 Skip := (if Is64 then 8 else 4); 1186 when DW_FORM_string => 1187 while uint8'(Read (S)) /= 0 loop 1188 null; 1189 end loop; 1190 return; 1191 when DW_FORM_indirect => 1192 raise Dwarf_Error with "DW_FORM_indirect not implemented"; 1193 when others => 1194 raise Dwarf_Error with "DWARF form not implemented"; 1195 end case; 1196 1197 Seek (S, Tell (S) + Skip); 1198 end Skip_Form; 1199 1200 ----------------- 1201 -- Seek_Abbrev -- 1202 ----------------- 1203 1204 procedure Seek_Abbrev 1205 (C : in out Dwarf_Context; 1206 Abbrev_Offset : Offset; 1207 Abbrev_Num : uint32) 1208 is 1209 Abbrev : uint32; 1210 Tag : uint32; 1211 Has_Child : uint8; 1212 pragma Unreferenced (Tag, Has_Child); 1213 1214 begin 1215 Seek (C.Abbrev, Abbrev_Offset); 1216 1217 -- 7.5.3 Abbreviations Tables 1218 1219 loop 1220 Abbrev := Read_LEB128 (C.Abbrev); 1221 1222 exit when Abbrev = Abbrev_Num; 1223 1224 Tag := Read_LEB128 (C.Abbrev); 1225 Has_Child := Read (C.Abbrev); 1226 1227 loop 1228 declare 1229 Name : constant uint32 := Read_LEB128 (C.Abbrev); 1230 Form : constant uint32 := Read_LEB128 (C.Abbrev); 1231 Cst : int32; 1232 pragma Unreferenced (Cst); 1233 1234 begin 1235 -- DW_FORM_implicit_const takes its value from the table 1236 1237 if Form = DW_FORM_implicit_const then 1238 Cst := Read_LEB128 (C.Abbrev); 1239 end if; 1240 1241 exit when Name = 0 and then Form = 0; 1242 end; 1243 end loop; 1244 end loop; 1245 end Seek_Abbrev; 1246 1247 ----------------------- 1248 -- Debug_Info_Lookup -- 1249 ----------------------- 1250 1251 procedure Debug_Info_Lookup 1252 (C : in out Dwarf_Context; 1253 Info_Offset : Offset; 1254 Line_Offset : out Offset; 1255 Success : out Boolean) 1256 is 1257 Unit_Length : Offset; 1258 Is64 : Boolean; 1259 Version : uint16; 1260 Abbrev_Offset : Offset; 1261 Addr_Sz : uint8; 1262 Abbrev : uint32; 1263 Has_Child : uint8; 1264 pragma Unreferenced (Has_Child); 1265 Unit_Type : uint8; 1266 pragma Unreferenced (Unit_Type); 1267 1268 begin 1269 Line_Offset := 0; 1270 Success := False; 1271 1272 Seek (C.Info, Info_Offset); 1273 1274 -- 7.5.1.1 Compilation Unit Header 1275 1276 Read_Initial_Length (C.Info, Unit_Length, Is64); 1277 1278 Version := Read (C.Info); 1279 1280 if Version >= 5 then 1281 Unit_Type := Read (C.Info); 1282 1283 Addr_Sz := Read (C.Info); 1284 if Addr_Sz /= (Address'Size / SSU) then 1285 return; 1286 end if; 1287 1288 Read_Section_Offset (C.Info, Abbrev_Offset, Is64); 1289 1290 elsif Version >= 2 then 1291 Read_Section_Offset (C.Info, Abbrev_Offset, Is64); 1292 1293 Addr_Sz := Read (C.Info); 1294 if Addr_Sz /= (Address'Size / SSU) then 1295 return; 1296 end if; 1297 1298 else 1299 return; 1300 end if; 1301 1302 -- Read DIEs 1303 1304 loop 1305 Abbrev := Read_LEB128 (C.Info); 1306 exit when Abbrev /= 0; 1307 end loop; 1308 1309 -- Read abbrev table 1310 1311 Seek_Abbrev (C, Abbrev_Offset, Abbrev); 1312 1313 -- Then the tag 1314 1315 if Read_LEB128 (C.Abbrev) /= uint32'(DW_TAG_Compile_Unit) then 1316 return; 1317 end if; 1318 1319 -- Then the has child flag 1320 1321 Has_Child := Read (C.Abbrev); 1322 1323 loop 1324 declare 1325 Name : constant uint32 := Read_LEB128 (C.Abbrev); 1326 Form : constant uint32 := Read_LEB128 (C.Abbrev); 1327 begin 1328 exit when Name = 0 and Form = 0; 1329 if Name = DW_AT_Stmt_List then 1330 case Form is 1331 when DW_FORM_sec_offset => 1332 Read_Section_Offset (C.Info, Line_Offset, Is64); 1333 when DW_FORM_data4 => 1334 Line_Offset := Offset (uint32'(Read (C.Info))); 1335 when DW_FORM_data8 => 1336 Line_Offset := Offset (uint64'(Read (C.Info))); 1337 when others => 1338 -- Unhandled form 1339 return; 1340 end case; 1341 1342 Success := True; 1343 return; 1344 else 1345 Skip_Form (C.Info, Form, Is64, Addr_Sz); 1346 end if; 1347 end; 1348 end loop; 1349 end Debug_Info_Lookup; 1350 1351 ------------------------- 1352 -- Read_Aranges_Header -- 1353 ------------------------- 1354 1355 procedure Read_Aranges_Header 1356 (C : in out Dwarf_Context; 1357 Info_Offset : out Offset; 1358 Success : out Boolean) 1359 is 1360 Unit_Length : Offset; 1361 Is64 : Boolean; 1362 Version : uint16; 1363 Sz : uint8; 1364 1365 begin 1366 Success := False; 1367 Info_Offset := 0; 1368 1369 Read_Initial_Length (C.Aranges, Unit_Length, Is64); 1370 1371 Version := Read (C.Aranges); 1372 if Version /= 2 then 1373 return; 1374 end if; 1375 1376 Read_Section_Offset (C.Aranges, Info_Offset, Is64); 1377 1378 -- Read address_size (ubyte) 1379 1380 Sz := Read (C.Aranges); 1381 if Sz /= (Address'Size / SSU) then 1382 return; 1383 end if; 1384 1385 -- Read segment_size (ubyte) 1386 1387 Sz := Read (C.Aranges); 1388 if Sz /= 0 then 1389 return; 1390 end if; 1391 1392 -- Handle alignment on twice the address size 1393 1394 declare 1395 Cur_Off : constant Offset := Tell (C.Aranges); 1396 Align : constant Offset := 2 * Address'Size / SSU; 1397 Space : constant Offset := Cur_Off mod Align; 1398 begin 1399 if Space /= 0 then 1400 Seek (C.Aranges, Cur_Off + Align - Space); 1401 end if; 1402 end; 1403 1404 Success := True; 1405 end Read_Aranges_Header; 1406 1407 ------------------------ 1408 -- Read_Aranges_Entry -- 1409 ------------------------ 1410 1411 procedure Read_Aranges_Entry 1412 (C : in out Dwarf_Context; 1413 Start : out Address; 1414 Len : out Storage_Count) 1415 is 1416 begin 1417 -- Read table 1418 1419 if Address'Size = 32 then 1420 declare 1421 S, L : uint32; 1422 begin 1423 S := Read (C.Aranges); 1424 L := Read (C.Aranges); 1425 Start := Address (S); 1426 Len := Storage_Count (L); 1427 end; 1428 1429 elsif Address'Size = 64 then 1430 declare 1431 S, L : uint64; 1432 begin 1433 S := Read (C.Aranges); 1434 L := Read (C.Aranges); 1435 Start := Address (S); 1436 Len := Storage_Count (L); 1437 end; 1438 1439 else 1440 raise Constraint_Error; 1441 end if; 1442 end Read_Aranges_Entry; 1443 1444 ------------------ 1445 -- Enable_Cache -- 1446 ------------------ 1447 1448 procedure Enable_Cache (C : in out Dwarf_Context) is 1449 Cache : Search_Array_Access; 1450 1451 begin 1452 -- Phase 1: count number of symbols. 1453 -- Phase 2: fill the cache. 1454 1455 declare 1456 S : Object_Symbol; 1457 Val : uint64; 1458 Xcode_Low : constant uint64 := uint64 (C.Low); 1459 Xcode_High : constant uint64 := uint64 (C.High); 1460 Sz : uint32; 1461 Addr, Prev_Addr : uint32; 1462 Nbr_Symbols : Natural; 1463 begin 1464 for Phase in 1 .. 2 loop 1465 Nbr_Symbols := 0; 1466 S := First_Symbol (C.Obj.all); 1467 Prev_Addr := uint32'Last; 1468 while S /= Null_Symbol loop 1469 -- Discard symbols of length 0 or located outside of the 1470 -- execution code section outer boundaries. 1471 1472 Sz := uint32 (Size (S)); 1473 Val := Value (S); 1474 1475 if Sz > 0 1476 and then Val >= Xcode_Low 1477 and then Val <= Xcode_High 1478 then 1479 Addr := uint32 (Val - Xcode_Low); 1480 1481 -- Try to filter symbols at the same address. This is a best 1482 -- effort as they might not be consecutive. 1483 1484 if Addr /= Prev_Addr then 1485 Nbr_Symbols := Nbr_Symbols + 1; 1486 Prev_Addr := Addr; 1487 1488 if Phase = 2 then 1489 C.Cache (Nbr_Symbols) := 1490 (First => Addr, 1491 Size => Sz, 1492 Sym => uint32 (Off (S)), 1493 Line => 0); 1494 end if; 1495 end if; 1496 end if; 1497 1498 S := Next_Symbol (C.Obj.all, S); 1499 end loop; 1500 1501 if Phase = 1 then 1502 -- Allocate the cache 1503 1504 Cache := new Search_Array (1 .. Nbr_Symbols); 1505 C.Cache := Cache; 1506 end if; 1507 end loop; 1508 pragma Assert (Nbr_Symbols = C.Cache'Last); 1509 end; 1510 1511 -- Sort the cache 1512 1513 Sort_Search_Array (C.Cache.all); 1514 1515 -- Set line offsets 1516 1517 if not C.Has_Debug then 1518 return; 1519 end if; 1520 1521 declare 1522 Info_Offset : Offset; 1523 Line_Offset : Offset; 1524 Success : Boolean; 1525 Ar_Start : Address; 1526 Ar_Len : Storage_Count; 1527 Start, Len : uint32; 1528 First, Last : Natural; 1529 Mid : Natural; 1530 1531 begin 1532 Seek (C.Aranges, 0); 1533 1534 while Tell (C.Aranges) < Length (C.Aranges) loop 1535 Read_Aranges_Header (C, Info_Offset, Success); 1536 exit when not Success; 1537 1538 Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); 1539 exit when not Success; 1540 1541 -- Read table 1542 1543 loop 1544 Read_Aranges_Entry (C, Ar_Start, Ar_Len); 1545 exit when Ar_Start = Null_Address and Ar_Len = 0; 1546 1547 Len := uint32 (Ar_Len); 1548 Start := uint32 (Ar_Start - C.Low); 1549 1550 -- Search START in the array 1551 1552 First := Cache'First; 1553 Last := Cache'Last; 1554 Mid := First; -- In case of array with one element 1555 while First < Last loop 1556 Mid := First + (Last - First) / 2; 1557 if Start < Cache (Mid).First then 1558 Last := Mid - 1; 1559 elsif Start >= Cache (Mid).First + Cache (Mid).Size then 1560 First := Mid + 1; 1561 else 1562 exit; 1563 end if; 1564 end loop; 1565 1566 -- Fill info 1567 1568 -- There can be overlapping symbols 1569 1570 while Mid > Cache'First 1571 and then Cache (Mid - 1).First <= Start 1572 and then Cache (Mid - 1).First + Cache (Mid - 1).Size > Start 1573 loop 1574 Mid := Mid - 1; 1575 end loop; 1576 while Mid <= Cache'Last loop 1577 if Start < Cache (Mid).First + Cache (Mid).Size 1578 and then Start + Len > Cache (Mid).First 1579 then 1580 -- MID is within the bounds 1581 1582 Cache (Mid).Line := uint32 (Line_Offset); 1583 elsif Start + Len <= Cache (Mid).First then 1584 -- Over 1585 1586 exit; 1587 end if; 1588 Mid := Mid + 1; 1589 end loop; 1590 end loop; 1591 end loop; 1592 end; 1593 end Enable_Cache; 1594 1595 ---------------------- 1596 -- Symbolic_Address -- 1597 ---------------------- 1598 1599 procedure Symbolic_Address 1600 (C : in out Dwarf_Context; 1601 Addr : Address; 1602 Dir_Name : out Str_Access; 1603 File_Name : out Str_Access; 1604 Subprg_Name : out String_Ptr_Len; 1605 Line_Num : out Natural) 1606 is 1607 procedure Set_Result (Match : Line_Info_Registers); 1608 -- Set results using match 1609 1610 procedure Set_Result (Match : Line_Info_Registers) is 1611 Dir_Idx : uint32; 1612 Off : Offset; 1613 1614 Mod_Time : uint32; 1615 pragma Unreferenced (Mod_Time); 1616 1617 Length : uint32; 1618 pragma Unreferenced (Length); 1619 1620 Directory_Entry_Format : Entry_Format_Array 1621 renames C.Header.Directory_Entry_Format; 1622 1623 File_Entry_Format : Entry_Format_Array 1624 renames C.Header.File_Name_Entry_Format; 1625 1626 begin 1627 Seek (C.Lines, C.Header.File_Names); 1628 Dir_Idx := 0; 1629 1630 -- Find the entry. Note that, up to DWARF 4, the index is 1-based 1631 -- whereas, in DWARF 5, it is 0-based. 1632 1633 if C.Header.Version <= 4 then 1634 for J in 1 .. Match.File loop 1635 File_Name := Read_C_String (C.Lines); 1636 1637 if File_Name (File_Name'First) = ASCII.NUL then 1638 -- End of file list, so incorrect entry 1639 return; 1640 end if; 1641 1642 Dir_Idx := Read_LEB128 (C.Lines); 1643 Mod_Time := Read_LEB128 (C.Lines); 1644 Length := Read_LEB128 (C.Lines); 1645 end loop; 1646 1647 if Dir_Idx = 0 then 1648 -- No directory 1649 1650 Dir_Name := null; 1651 1652 else 1653 Seek (C.Lines, C.Header.Directories); 1654 1655 for J in 1 .. Dir_Idx loop 1656 Dir_Name := Read_C_String (C.Lines); 1657 1658 if Dir_Name (Dir_Name'First) = ASCII.NUL then 1659 -- End of directory list, so ill-formed table 1660 1661 return; 1662 end if; 1663 end loop; 1664 end if; 1665 1666 -- DWARF 5 1667 1668 else 1669 for J in 0 .. Match.File loop 1670 for K in 1 .. Integer (C.Header.File_Name_Entry_Format_Count) 1671 loop 1672 if File_Entry_Format (K).C_Type = DW_LNCT_path then 1673 case File_Entry_Format (K).Form is 1674 when DW_FORM_string => 1675 File_Name := Read_C_String (C.Lines); 1676 1677 when DW_FORM_line_strp => 1678 Read_Section_Offset (C.Lines, Off, C.Header.Is64); 1679 if J = Match.File then 1680 Seek (C.Line_Str, Off); 1681 File_Name := Read_C_String (C.Line_Str); 1682 end if; 1683 1684 when others => 1685 raise Dwarf_Error with "DWARF form not implemented"; 1686 end case; 1687 1688 elsif File_Entry_Format (K).C_Type = DW_LNCT_directory_index 1689 then 1690 case File_Entry_Format (K).Form is 1691 when DW_FORM_data1 => 1692 Dir_Idx := uint32 (uint8'(Read (C.Lines))); 1693 1694 when DW_FORM_data2 => 1695 Dir_Idx := uint32 (uint16'(Read (C.Lines))); 1696 1697 when DW_FORM_udata => 1698 Dir_Idx := Read_LEB128 (C.Lines); 1699 1700 when others => 1701 raise Dwarf_Error with 1702 "invalid DWARF form for DW_LNCT_directory_index"; 1703 end case; 1704 1705 else 1706 Skip_Form (C.Lines, 1707 File_Entry_Format (K).Form, 1708 C.Header.Is64, 1709 C.Header.Address_Size); 1710 end if; 1711 end loop; 1712 end loop; 1713 1714 Seek (C.Lines, C.Header.Directories); 1715 1716 for J in 0 .. Dir_Idx loop 1717 for K in 1 .. Integer (C.Header.Directory_Entry_Format_Count) 1718 loop 1719 if Directory_Entry_Format (K).C_Type = DW_LNCT_path then 1720 case Directory_Entry_Format (K).Form is 1721 when DW_FORM_string => 1722 Dir_Name := Read_C_String (C.Lines); 1723 1724 when DW_FORM_line_strp => 1725 Read_Section_Offset (C.Lines, Off, C.Header.Is64); 1726 if J = Dir_Idx then 1727 Seek (C.Line_Str, Off); 1728 Dir_Name := Read_C_String (C.Line_Str); 1729 end if; 1730 1731 when others => 1732 raise Dwarf_Error with "DWARF form not implemented"; 1733 end case; 1734 1735 else 1736 Skip_Form (C.Lines, 1737 Directory_Entry_Format (K).Form, 1738 C.Header.Is64, 1739 C.Header.Address_Size); 1740 end if; 1741 end loop; 1742 end loop; 1743 end if; 1744 1745 Line_Num := Natural (Match.Line); 1746 end Set_Result; 1747 1748 Addr_Int : constant uint64 := uint64 (Addr); 1749 Previous_Row : Line_Info_Registers; 1750 Info_Offset : Offset; 1751 Line_Offset : Offset; 1752 Success : Boolean; 1753 Done : Boolean; 1754 S : Object_Symbol; 1755 1756 begin 1757 -- Initialize result 1758 1759 Dir_Name := null; 1760 File_Name := null; 1761 Subprg_Name := (null, 0); 1762 Line_Num := 0; 1763 1764 -- Look up the symbol in the cache 1765 1766 if C.Cache /= null then 1767 declare 1768 Addr_Off : constant uint32 := uint32 (Addr - C.Low); 1769 First, Last, Mid : Natural; 1770 begin 1771 First := C.Cache'First; 1772 Last := C.Cache'Last; 1773 Mid := First; 1774 1775 while First <= Last loop 1776 Mid := First + (Last - First) / 2; 1777 if Addr_Off < C.Cache (Mid).First then 1778 Last := Mid - 1; 1779 elsif Addr_Off >= C.Cache (Mid).First + C.Cache (Mid).Size then 1780 First := Mid + 1; 1781 else 1782 exit; 1783 end if; 1784 end loop; 1785 1786 if Addr_Off >= C.Cache (Mid).First 1787 and then Addr_Off < C.Cache (Mid).First + C.Cache (Mid).Size 1788 then 1789 Line_Offset := Offset (C.Cache (Mid).Line); 1790 S := Read_Symbol (C.Obj.all, Offset (C.Cache (Mid).Sym)); 1791 Subprg_Name := Object_Reader.Name (C.Obj.all, S); 1792 else 1793 return; 1794 end if; 1795 end; 1796 1797 -- Search for the symbol in the binary 1798 1799 else 1800 S := First_Symbol (C.Obj.all); 1801 while S /= Null_Symbol loop 1802 if Spans (S, Addr_Int) then 1803 Subprg_Name := Object_Reader.Name (C.Obj.all, S); 1804 exit; 1805 end if; 1806 1807 S := Next_Symbol (C.Obj.all, S); 1808 end loop; 1809 1810 -- Search address in aranges table 1811 1812 Aranges_Lookup (C, Addr, Info_Offset, Success); 1813 if not Success then 1814 return; 1815 end if; 1816 1817 -- Search stmt_list in info table 1818 1819 Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); 1820 if not Success then 1821 return; 1822 end if; 1823 end if; 1824 1825 Seek (C.Lines, Line_Offset); 1826 C.Next_Header := 0; 1827 Initialize_State_Machine (C); 1828 Parse_Header (C); 1829 Previous_Row.Line := 0; 1830 1831 -- Advance to the first entry 1832 1833 loop 1834 Read_And_Execute_Insn (C, Done); 1835 1836 if C.Registers.Is_Row then 1837 Previous_Row := C.Registers; 1838 exit; 1839 end if; 1840 1841 exit when Done; 1842 end loop; 1843 1844 -- Read the rest of the entries 1845 1846 while Tell (C.Lines) < C.Next_Header loop 1847 Read_And_Execute_Insn (C, Done); 1848 1849 if C.Registers.Is_Row then 1850 if not Previous_Row.End_Sequence 1851 and then Addr_Int >= Previous_Row.Address 1852 and then Addr_Int < C.Registers.Address 1853 then 1854 Set_Result (Previous_Row); 1855 return; 1856 1857 elsif Addr_Int = C.Registers.Address then 1858 Set_Result (C.Registers); 1859 return; 1860 end if; 1861 1862 Previous_Row := C.Registers; 1863 end if; 1864 1865 exit when Done; 1866 end loop; 1867 end Symbolic_Address; 1868 1869 ------------------- 1870 -- String_Length -- 1871 ------------------- 1872 1873 function String_Length (Str : Str_Access) return Natural is 1874 begin 1875 for I in Str'Range loop 1876 if Str (I) = ASCII.NUL then 1877 return I - Str'First; 1878 end if; 1879 end loop; 1880 1881 return Str'Last; 1882 end String_Length; 1883 1884 ------------------------ 1885 -- Symbolic_Traceback -- 1886 ------------------------ 1887 1888 procedure Symbolic_Traceback 1889 (Cin : Dwarf_Context; 1890 Traceback : STE.Tracebacks_Array; 1891 Suppress_Hex : Boolean; 1892 Symbol_Found : out Boolean; 1893 Res : in out System.Bounded_Strings.Bounded_String) 1894 is 1895 use Ada.Characters.Handling; 1896 C : Dwarf_Context := Cin; 1897 1898 Addr_In_Traceback : Address; 1899 1900 Dir_Name : Str_Access; 1901 File_Name : Str_Access; 1902 Subprg_Name : String_Ptr_Len; 1903 Line_Num : Natural; 1904 Off : Natural; 1905 1906 begin 1907 if not C.Has_Debug then 1908 Symbol_Found := False; 1909 return; 1910 else 1911 Symbol_Found := True; 1912 end if; 1913 1914 for J in Traceback'Range loop 1915 -- If the buffer is full, no need to do any useless work 1916 exit when Is_Full (Res); 1917 1918 Addr_In_Traceback := STE.PC_For (Traceback (J)); 1919 1920 Symbolic_Address 1921 (C, 1922 Addr_In_Traceback - Get_Load_Displacement (C), 1923 Dir_Name, 1924 File_Name, 1925 Subprg_Name, 1926 Line_Num); 1927 1928 -- If we're not requested to suppress hex addresses, emit it now. 1929 1930 if not Suppress_Hex then 1931 Append_Address (Res, Addr_In_Traceback); 1932 Append (Res, ' '); 1933 end if; 1934 1935 if File_Name /= null then 1936 declare 1937 Last : constant Natural := String_Length (File_Name); 1938 Is_Ada : constant Boolean := 1939 Last > 3 1940 and then 1941 To_Upper (String (File_Name (Last - 3 .. Last - 1))) = 1942 ".AD"; 1943 -- True if this is an Ada file. This doesn't take into account 1944 -- nonstandard file-naming conventions, but that's OK; this is 1945 -- purely cosmetic. It covers at least .ads, .adb, and .ada. 1946 1947 Line_Image : constant String := Natural'Image (Line_Num); 1948 begin 1949 if Subprg_Name.Len /= 0 then 1950 -- For Ada code, Symbol_Image is in all lower case; we don't 1951 -- have the case from the original source code. But the best 1952 -- guess is Mixed_Case, so convert to that. 1953 1954 if Is_Ada then 1955 declare 1956 Symbol_Image : String := 1957 Object_Reader.Decoded_Ada_Name 1958 (C.Obj.all, 1959 Subprg_Name); 1960 begin 1961 for K in Symbol_Image'Range loop 1962 if K = Symbol_Image'First 1963 or else not 1964 (Is_Letter (Symbol_Image (K - 1)) 1965 or else Is_Digit (Symbol_Image (K - 1))) 1966 then 1967 Symbol_Image (K) := To_Upper (Symbol_Image (K)); 1968 end if; 1969 end loop; 1970 Append (Res, Symbol_Image); 1971 end; 1972 else 1973 Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); 1974 1975 Append 1976 (Res, 1977 String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); 1978 end if; 1979 else 1980 Append (Res, "???"); 1981 end if; 1982 1983 Append (Res, " at "); 1984 Append (Res, String (File_Name (1 .. Last))); 1985 Append (Res, ':'); 1986 Append (Res, Line_Image (2 .. Line_Image'Last)); 1987 end; 1988 else 1989 if Subprg_Name.Len > 0 then 1990 Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); 1991 1992 Append (Res, String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); 1993 else 1994 Append (Res, "???"); 1995 end if; 1996 1997 Append (Res, " at ???"); 1998 end if; 1999 2000 Append (Res, ASCII.LF); 2001 end loop; 2002 end Symbolic_Traceback; 2003 2004end System.Dwarf_Lines; 2005