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-2019, 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 32pragma Polling (Off); 33-- We must turn polling off for this unit, because otherwise we can get 34-- elaboration circularities when polling is turned on 35 36with Ada.Characters.Handling; 37with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; 38with Ada.Unchecked_Deallocation; 39with Ada.Containers.Generic_Array_Sort; 40 41with Interfaces; use Interfaces; 42 43with System; use System; 44with System.Storage_Elements; use System.Storage_Elements; 45with System.Address_Image; 46with System.IO; use System.IO; 47with System.Object_Reader; use System.Object_Reader; 48with System.Traceback_Entries; use System.Traceback_Entries; 49with System.Mmap; use System.Mmap; 50with System.Bounded_Strings; use System.Bounded_Strings; 51 52package body System.Dwarf_Lines is 53 54 SSU : constant := System.Storage_Unit; 55 56 function String_Length (Str : Str_Access) return Natural; 57 -- Return the length of the C string Str 58 59 --------------------------------- 60 -- DWARF Parser Implementation -- 61 --------------------------------- 62 63 procedure Read_Initial_Length 64 (S : in out Mapped_Stream; 65 Len : out Offset; 66 Is64 : out Boolean); 67 -- Read initial length as specified by Dwarf-4 7.2.2 68 69 procedure Read_Section_Offset 70 (S : in out Mapped_Stream; 71 Len : out Offset; 72 Is64 : Boolean); 73 -- Read a section offset, as specified by Dwarf-4 7.4 74 75 procedure Read_Aranges_Entry 76 (C : in out Dwarf_Context; 77 Start : out Storage_Offset; 78 Len : out Storage_Count); 79 -- Read a single .debug_aranges pair 80 81 procedure Read_Aranges_Header 82 (C : in out Dwarf_Context; 83 Info_Offset : out Offset; 84 Success : out Boolean); 85 -- Read .debug_aranges header 86 87 procedure Aranges_Lookup 88 (C : in out Dwarf_Context; 89 Addr : Storage_Offset; 90 Info_Offset : out Offset; 91 Success : out Boolean); 92 -- Search for Addr in .debug_aranges and return offset Info_Offset in 93 -- .debug_info. 94 95 procedure Skip_Form 96 (S : in out Mapped_Stream; 97 Form : uint32; 98 Is64 : Boolean; 99 Ptr_Sz : uint8); 100 -- Advance offset in S for Form. 101 102 procedure Seek_Abbrev 103 (C : in out Dwarf_Context; 104 Abbrev_Offset : Offset; 105 Abbrev_Num : uint32); 106 -- Seek to abbrev Abbrev_Num (starting from Abbrev_Offset) 107 108 procedure Debug_Info_Lookup 109 (C : in out Dwarf_Context; 110 Info_Offset : Offset; 111 Line_Offset : out Offset; 112 Success : out Boolean); 113 -- Search for stmt_list tag in Info_Offset and set Line_Offset to the 114 -- offset in .debug_lines. Only look at the first DIE, which should be 115 -- a compilation unit. 116 117 procedure Initialize_Pass (C : in out Dwarf_Context); 118 -- Seek to the first byte of the first prologue and prepare to make a pass 119 -- over the line number entries. 120 121 procedure Initialize_State_Machine (C : in out Dwarf_Context); 122 -- Set all state machine registers to their specified initial values 123 124 procedure Parse_Prologue (C : in out Dwarf_Context); 125 -- Decode a DWARF statement program prologue 126 127 procedure Read_And_Execute_Isn 128 (C : in out Dwarf_Context; 129 Done : out Boolean); 130 -- Read an execute a statement program instruction 131 132 function To_File_Name 133 (C : in out Dwarf_Context; 134 Code : uint32) return String; 135 -- Extract a file name from the prologue 136 137 type Callback is access procedure (C : in out Dwarf_Context); 138 procedure For_Each_Row (C : in out Dwarf_Context; F : Callback); 139 -- Traverse each .debug_line entry with a callback 140 141 procedure Dump_Row (C : in out Dwarf_Context); 142 -- Dump a single row 143 144 function "<" (Left, Right : Search_Entry) return Boolean; 145 -- For sorting Search_Entry 146 147 procedure Sort_Search_Array is new Ada.Containers.Generic_Array_Sort 148 (Index_Type => Natural, 149 Element_Type => Search_Entry, 150 Array_Type => Search_Array); 151 152 procedure Symbolic_Address 153 (C : in out Dwarf_Context; 154 Addr : Storage_Offset; 155 Dir_Name : out Str_Access; 156 File_Name : out Str_Access; 157 Subprg_Name : out String_Ptr_Len; 158 Line_Num : out Natural); 159 -- Symbolize one address 160 161 ----------------------- 162 -- DWARF constants -- 163 ----------------------- 164 165 -- 6.2.5.2 Standard Opcodes 166 167 DW_LNS_copy : constant := 1; 168 DW_LNS_advance_pc : constant := 2; 169 DW_LNS_advance_line : constant := 3; 170 DW_LNS_set_file : constant := 4; 171 DW_LNS_set_column : constant := 5; 172 DW_LNS_negate_stmt : constant := 6; 173 DW_LNS_set_basic_block : constant := 7; 174 DW_LNS_const_add_pc : constant := 8; 175 DW_LNS_fixed_advance_pc : constant := 9; 176 DW_LNS_set_prologue_end : constant := 10; 177 DW_LNS_set_epilogue_begin : constant := 11; 178 DW_LNS_set_isa : constant := 12; 179 180 -- 6.2.5.3 Extended Opcodes 181 182 DW_LNE_end_sequence : constant := 1; 183 DW_LNE_set_address : constant := 2; 184 DW_LNE_define_file : constant := 3; 185 186 -- From the DWARF version 4 public review draft 187 188 DW_LNE_set_discriminator : constant := 4; 189 190 -- Attribute encodings 191 192 DW_TAG_Compile_Unit : constant := 16#11#; 193 194 DW_AT_Stmt_List : constant := 16#10#; 195 196 DW_FORM_addr : constant := 16#01#; 197 DW_FORM_block2 : constant := 16#03#; 198 DW_FORM_block4 : constant := 16#04#; 199 DW_FORM_data2 : constant := 16#05#; 200 DW_FORM_data4 : constant := 16#06#; 201 DW_FORM_data8 : constant := 16#07#; 202 DW_FORM_string : constant := 16#08#; 203 DW_FORM_block : constant := 16#09#; 204 DW_FORM_block1 : constant := 16#0a#; 205 DW_FORM_data1 : constant := 16#0b#; 206 DW_FORM_flag : constant := 16#0c#; 207 DW_FORM_sdata : constant := 16#0d#; 208 DW_FORM_strp : constant := 16#0e#; 209 DW_FORM_udata : constant := 16#0f#; 210 DW_FORM_ref_addr : constant := 16#10#; 211 DW_FORM_ref1 : constant := 16#11#; 212 DW_FORM_ref2 : constant := 16#12#; 213 DW_FORM_ref4 : constant := 16#13#; 214 DW_FORM_ref8 : constant := 16#14#; 215 DW_FORM_ref_udata : constant := 16#15#; 216 DW_FORM_indirect : constant := 16#16#; 217 DW_FORM_sec_offset : constant := 16#17#; 218 DW_FORM_exprloc : constant := 16#18#; 219 DW_FORM_flag_present : constant := 16#19#; 220 DW_FORM_ref_sig8 : constant := 16#20#; 221 222 --------- 223 -- "<" -- 224 --------- 225 226 function "<" (Left, Right : Search_Entry) return Boolean is 227 begin 228 return Left.First < Right.First; 229 end "<"; 230 231 ----------- 232 -- Close -- 233 ----------- 234 235 procedure Close (C : in out Dwarf_Context) is 236 procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation 237 (Object_File, 238 Object_File_Access); 239 procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation 240 (Search_Array, 241 Search_Array_Access); 242 begin 243 if C.Has_Debug then 244 Close (C.Lines); 245 Close (C.Abbrev); 246 Close (C.Info); 247 Close (C.Aranges); 248 end if; 249 250 Close (C.Obj.all); 251 Unchecked_Deallocation (C.Obj); 252 253 Unchecked_Deallocation (C.Cache); 254 end Close; 255 256 ---------- 257 -- Dump -- 258 ---------- 259 260 procedure Dump (C : in out Dwarf_Context) is 261 begin 262 For_Each_Row (C, Dump_Row'Access); 263 end Dump; 264 265 -------------- 266 -- Dump_Row -- 267 -------------- 268 269 procedure Dump_Row (C : in out Dwarf_Context) is 270 PC : constant Integer_Address := Integer_Address (C.Registers.Address); 271 Off : Offset; 272 begin 273 Tell (C.Lines, Off); 274 275 Put (System.Address_Image (To_Address (PC))); 276 Put (" "); 277 Put (To_File_Name (C, C.Registers.File)); 278 Put (":"); 279 280 declare 281 Image : constant String := uint32'Image (C.Registers.Line); 282 begin 283 Put_Line (Image (2 .. Image'Last)); 284 end; 285 286 Seek (C.Lines, Off); 287 end Dump_Row; 288 289 procedure Dump_Cache (C : Dwarf_Context) is 290 Cache : constant Search_Array_Access := C.Cache; 291 S : Object_Symbol; 292 Name : String_Ptr_Len; 293 begin 294 if Cache = null then 295 Put_Line ("No cache"); 296 return; 297 end if; 298 for I in Cache'Range loop 299 declare 300 E : Search_Entry renames Cache (I); 301 Base_Address : constant System.Address := 302 To_Address (Integer_Address (C.Low + Storage_Count (E.First))); 303 begin 304 Put (System.Address_Image (Base_Address)); 305 Put (" - "); 306 Put (System.Address_Image (Base_Address + Storage_Count (E.Size))); 307 Put (" l@"); 308 Put (System.Address_Image (To_Address (Integer_Address (E.Line)))); 309 Put (": "); 310 S := Read_Symbol (C.Obj.all, Offset (E.Sym)); 311 Name := Object_Reader.Name (C.Obj.all, S); 312 Put (String (Name.Ptr (1 .. Name.Len))); 313 New_Line; 314 end; 315 end loop; 316 end Dump_Cache; 317 318 ------------------ 319 -- For_Each_Row -- 320 ------------------ 321 322 procedure For_Each_Row (C : in out Dwarf_Context; F : Callback) is 323 Done : Boolean; 324 325 begin 326 Initialize_Pass (C); 327 328 loop 329 Read_And_Execute_Isn (C, Done); 330 331 if C.Registers.Is_Row then 332 F.all (C); 333 end if; 334 335 exit when Done; 336 end loop; 337 end For_Each_Row; 338 339 --------------------- 340 -- Initialize_Pass -- 341 --------------------- 342 343 procedure Initialize_Pass (C : in out Dwarf_Context) is 344 begin 345 Seek (C.Lines, 0); 346 C.Next_Prologue := 0; 347 348 Initialize_State_Machine (C); 349 end Initialize_Pass; 350 351 ------------------------------ 352 -- Initialize_State_Machine -- 353 ------------------------------ 354 355 procedure Initialize_State_Machine (C : in out Dwarf_Context) is 356 begin 357 C.Registers := 358 (Address => 0, 359 File => 1, 360 Line => 1, 361 Column => 0, 362 Is_Stmt => C.Prologue.Default_Is_Stmt = 0, 363 Basic_Block => False, 364 End_Sequence => False, 365 Prologue_End => False, 366 Epilogue_Begin => False, 367 ISA => 0, 368 Is_Row => False); 369 end Initialize_State_Machine; 370 371 --------------- 372 -- Is_Inside -- 373 --------------- 374 375 function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is 376 begin 377 return (Addr >= C.Low + C.Load_Address 378 and then Addr <= C.High + C.Load_Address); 379 end Is_Inside; 380 381 ----------------- 382 -- Low_Address -- 383 ----------------- 384 385 function Low_Address (C : Dwarf_Context) 386 return System.Address is 387 begin 388 return C.Load_Address + C.Low; 389 end Low_Address; 390 391 ---------- 392 -- Open -- 393 ---------- 394 395 procedure Open 396 (File_Name : String; 397 C : out Dwarf_Context; 398 Success : out Boolean) 399 is 400 Line_Sec, Info_Sec, Abbrev_Sec, Aranges_Sec : Object_Section; 401 Hi, Lo : uint64; 402 begin 403 -- Not a success by default 404 405 Success := False; 406 407 -- Open file 408 409 C.Obj := Open (File_Name, C.In_Exception); 410 411 if C.Obj = null then 412 return; 413 end if; 414 415 Success := True; 416 417 -- Get memory bounds for executable code. Note that such code 418 -- might come from multiple sections. 419 420 Get_Xcode_Bounds (C.Obj.all, Lo, Hi); 421 C.Low := Storage_Offset (Lo); 422 C.High := Storage_Offset (Hi); 423 424 -- Create a stream for debug sections 425 426 if Format (C.Obj.all) = XCOFF32 then 427 Line_Sec := Get_Section (C.Obj.all, ".dwline"); 428 Abbrev_Sec := Get_Section (C.Obj.all, ".dwabrev"); 429 Info_Sec := Get_Section (C.Obj.all, ".dwinfo"); 430 Aranges_Sec := Get_Section (C.Obj.all, ".dwarnge"); 431 else 432 Line_Sec := Get_Section (C.Obj.all, ".debug_line"); 433 Abbrev_Sec := Get_Section (C.Obj.all, ".debug_abbrev"); 434 Info_Sec := Get_Section (C.Obj.all, ".debug_info"); 435 Aranges_Sec := Get_Section (C.Obj.all, ".debug_aranges"); 436 end if; 437 438 if Line_Sec = Null_Section 439 or else Abbrev_Sec = Null_Section 440 or else Info_Sec = Null_Section 441 or else Aranges_Sec = Null_Section 442 then 443 C.Has_Debug := False; 444 return; 445 end if; 446 447 C.Lines := Create_Stream (C.Obj.all, Line_Sec); 448 C.Abbrev := Create_Stream (C.Obj.all, Abbrev_Sec); 449 C.Info := Create_Stream (C.Obj.all, Info_Sec); 450 C.Aranges := Create_Stream (C.Obj.all, Aranges_Sec); 451 452 -- All operations are successful, context is valid 453 454 C.Has_Debug := True; 455 end Open; 456 457 -------------------- 458 -- Parse_Prologue -- 459 -------------------- 460 461 procedure Parse_Prologue (C : in out Dwarf_Context) is 462 Char : uint8; 463 Prev : uint8; 464 -- The most recently read character and the one preceding it 465 466 Dummy : uint32; 467 -- Destination for reads we don't care about 468 469 Buf : Buffer; 470 Off : Offset; 471 472 First_Byte_Of_Prologue : Offset; 473 Last_Byte_Of_Prologue : Offset; 474 475 Max_Op_Per_Insn : uint8; 476 pragma Unreferenced (Max_Op_Per_Insn); 477 478 Prologue : Line_Info_Prologue renames C.Prologue; 479 480 begin 481 Tell (C.Lines, First_Byte_Of_Prologue); 482 Prologue.Unit_Length := Read (C.Lines); 483 Tell (C.Lines, Off); 484 C.Next_Prologue := Off + Offset (Prologue.Unit_Length); 485 486 Prologue.Version := Read (C.Lines); 487 Prologue.Prologue_Length := Read (C.Lines); 488 Tell (C.Lines, Last_Byte_Of_Prologue); 489 Last_Byte_Of_Prologue := 490 Last_Byte_Of_Prologue + Offset (Prologue.Prologue_Length) - 1; 491 492 Prologue.Min_Isn_Length := Read (C.Lines); 493 494 if Prologue.Version >= 4 then 495 Max_Op_Per_Insn := Read (C.Lines); 496 end if; 497 498 Prologue.Default_Is_Stmt := Read (C.Lines); 499 Prologue.Line_Base := Read (C.Lines); 500 Prologue.Line_Range := Read (C.Lines); 501 Prologue.Opcode_Base := Read (C.Lines); 502 503 -- Opcode_Lengths is an array of Opcode_Base bytes specifying the number 504 -- of LEB128 operands for each of the standard opcodes. 505 506 for J in 1 .. uint32 (Prologue.Opcode_Base - 1) loop 507 Prologue.Opcode_Lengths (J) := Read (C.Lines); 508 end loop; 509 510 -- The include directories table follows. This is a list of null 511 -- terminated strings terminated by a double null. We only store 512 -- its offset for later decoding. 513 514 Tell (C.Lines, Prologue.Includes_Offset); 515 Char := Read (C.Lines); 516 517 if Char /= 0 then 518 loop 519 Prev := Char; 520 Char := Read (C.Lines); 521 exit when Char = 0 and Prev = 0; 522 end loop; 523 end if; 524 525 -- The file_names table is next. Each record is a null terminated string 526 -- for the file name, an unsigned LEB128 directory index, an unsigned 527 -- LEB128 modification time, and an LEB128 file length. The table is 528 -- terminated by a null byte. 529 530 Tell (C.Lines, Prologue.File_Names_Offset); 531 532 loop 533 -- Read the filename 534 535 Read_C_String (C.Lines, Buf); 536 exit when Buf (0) = 0; 537 Dummy := Read_LEB128 (C.Lines); -- Skip the directory index. 538 Dummy := Read_LEB128 (C.Lines); -- Skip the modification time. 539 Dummy := Read_LEB128 (C.Lines); -- Skip the file length. 540 end loop; 541 542 -- Check we're where we think we are. This sanity check ensures we think 543 -- the prologue ends where the prologue says it does. It we aren't then 544 -- we've probably gotten out of sync somewhere. 545 546 Tell (C.Lines, Off); 547 548 if Prologue.Unit_Length /= 0 549 and then Off /= Last_Byte_Of_Prologue + 1 550 then 551 raise Dwarf_Error with "Parse error reading DWARF information"; 552 end if; 553 end Parse_Prologue; 554 555 -------------------------- 556 -- Read_And_Execute_Isn -- 557 -------------------------- 558 559 procedure Read_And_Execute_Isn 560 (C : in out Dwarf_Context; 561 Done : out Boolean) 562 is 563 Opcode : uint8; 564 Extended_Opcode : uint8; 565 uint32_Operand : uint32; 566 int32_Operand : int32; 567 uint16_Operand : uint16; 568 Off : Offset; 569 570 Extended_Length : uint32; 571 pragma Unreferenced (Extended_Length); 572 573 Obj : Object_File renames C.Obj.all; 574 Registers : Line_Info_Registers renames C.Registers; 575 Prologue : Line_Info_Prologue renames C.Prologue; 576 577 begin 578 Done := False; 579 Registers.Is_Row := False; 580 581 if Registers.End_Sequence then 582 Initialize_State_Machine (C); 583 end if; 584 585 -- If we have reached the next prologue, read it. Beware of possibly 586 -- empty blocks. 587 588 -- When testing for the end of section, beware of possible zero padding 589 -- at the end. Bail out as soon as there's not even room for at least a 590 -- DW_LNE_end_sequence, 3 bytes from Off to Off+2. This resolves to 591 -- Off+2 > Last_Offset_Within_Section, that is Off+2 > Section_Length-1, 592 -- or Off+3 > Section_Length. 593 594 Tell (C.Lines, Off); 595 while Off = C.Next_Prologue loop 596 Initialize_State_Machine (C); 597 Parse_Prologue (C); 598 Tell (C.Lines, Off); 599 exit when Off + 3 > Length (C.Lines); 600 end loop; 601 602 -- Test whether we're done 603 604 Tell (C.Lines, Off); 605 606 -- We are finished when we either reach the end of the section, or we 607 -- have reached zero padding at the end of the section. 608 609 if Prologue.Unit_Length = 0 or else Off + 3 > Length (C.Lines) then 610 Done := True; 611 return; 612 end if; 613 614 -- Read and interpret an instruction 615 616 Opcode := Read (C.Lines); 617 618 -- Extended opcodes 619 620 if Opcode = 0 then 621 Extended_Length := Read_LEB128 (C.Lines); 622 Extended_Opcode := Read (C.Lines); 623 624 case Extended_Opcode is 625 when DW_LNE_end_sequence => 626 627 -- Mark the end of a sequence of source locations 628 629 Registers.End_Sequence := True; 630 Registers.Is_Row := True; 631 632 when DW_LNE_set_address => 633 634 -- Set the program counter to a word 635 636 Registers.Address := Read_Address (Obj, C.Lines); 637 638 when DW_LNE_define_file => 639 640 -- Not implemented 641 642 raise Dwarf_Error with "DWARF operator not implemented"; 643 644 when DW_LNE_set_discriminator => 645 646 -- Ignored 647 648 int32_Operand := Read_LEB128 (C.Lines); 649 650 when others => 651 652 -- Fail on an unrecognized opcode 653 654 raise Dwarf_Error with "DWARF operator not implemented"; 655 end case; 656 657 -- Standard opcodes 658 659 elsif Opcode < Prologue.Opcode_Base then 660 case Opcode is 661 662 -- Append a row to the line info matrix 663 664 when DW_LNS_copy => 665 Registers.Basic_Block := False; 666 Registers.Is_Row := True; 667 668 -- Add an unsigned word to the program counter 669 670 when DW_LNS_advance_pc => 671 uint32_Operand := Read_LEB128 (C.Lines); 672 Registers.Address := 673 Registers.Address + 674 uint64 (uint32_Operand * uint32 (Prologue.Min_Isn_Length)); 675 676 -- Add a signed word to the current source line 677 678 when DW_LNS_advance_line => 679 int32_Operand := Read_LEB128 (C.Lines); 680 Registers.Line := 681 uint32 (int32 (Registers.Line) + int32_Operand); 682 683 -- Set the current source file 684 685 when DW_LNS_set_file => 686 uint32_Operand := Read_LEB128 (C.Lines); 687 Registers.File := uint32_Operand; 688 689 -- Set the current source column 690 691 when DW_LNS_set_column => 692 uint32_Operand := Read_LEB128 (C.Lines); 693 Registers.Column := uint32_Operand; 694 695 -- Toggle the "is statement" flag. GCC doesn't seem to set this??? 696 697 when DW_LNS_negate_stmt => 698 Registers.Is_Stmt := not Registers.Is_Stmt; 699 700 -- Mark the beginning of a basic block 701 702 when DW_LNS_set_basic_block => 703 Registers.Basic_Block := True; 704 705 -- Advance the program counter as by the special opcode 255 706 707 when DW_LNS_const_add_pc => 708 Registers.Address := 709 Registers.Address + 710 uint64 711 (((255 - Prologue.Opcode_Base) / Prologue.Line_Range) * 712 Prologue.Min_Isn_Length); 713 714 -- Advance the program counter by a constant 715 716 when DW_LNS_fixed_advance_pc => 717 uint16_Operand := Read (C.Lines); 718 Registers.Address := 719 Registers.Address + uint64 (uint16_Operand); 720 721 -- The following are not implemented and ignored 722 723 when DW_LNS_set_prologue_end => 724 null; 725 726 when DW_LNS_set_epilogue_begin => 727 null; 728 729 when DW_LNS_set_isa => 730 null; 731 732 -- Anything else is an error 733 734 when others => 735 raise Dwarf_Error with "DWARF operator not implemented"; 736 end case; 737 738 -- Decode a special opcode. This is a line and address increment encoded 739 -- in a single byte 'special opcode' as described in 6.2.5.1. 740 741 else 742 declare 743 Address_Increment : int32; 744 Line_Increment : int32; 745 746 begin 747 Opcode := Opcode - Prologue.Opcode_Base; 748 749 -- The adjusted opcode is a uint8 encoding an address increment 750 -- and a signed line increment. The upperbound is allowed to be 751 -- greater than int8'last so we decode using int32 directly to 752 -- prevent overflows. 753 754 Address_Increment := 755 int32 (Opcode / Prologue.Line_Range) * 756 int32 (Prologue.Min_Isn_Length); 757 Line_Increment := 758 int32 (Prologue.Line_Base) + 759 int32 (Opcode mod Prologue.Line_Range); 760 761 Registers.Address := 762 Registers.Address + uint64 (Address_Increment); 763 Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment); 764 Registers.Basic_Block := False; 765 Registers.Prologue_End := False; 766 Registers.Epilogue_Begin := False; 767 Registers.Is_Row := True; 768 end; 769 end if; 770 771 exception 772 when Dwarf_Error => 773 774 -- In case of errors during parse, just stop reading 775 776 Registers.Is_Row := False; 777 Done := True; 778 end Read_And_Execute_Isn; 779 780 ---------------------- 781 -- Set_Load_Address -- 782 ---------------------- 783 784 procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is 785 begin 786 C.Load_Address := Addr; 787 end Set_Load_Address; 788 789 ------------------ 790 -- To_File_Name -- 791 ------------------ 792 793 function To_File_Name 794 (C : in out Dwarf_Context; 795 Code : uint32) return String 796 is 797 Buf : Buffer; 798 J : uint32; 799 800 Dir_Idx : uint32; 801 pragma Unreferenced (Dir_Idx); 802 803 Mod_Time : uint32; 804 pragma Unreferenced (Mod_Time); 805 806 Length : uint32; 807 pragma Unreferenced (Length); 808 809 begin 810 Seek (C.Lines, C.Prologue.File_Names_Offset); 811 812 -- Find the entry 813 814 J := 0; 815 loop 816 J := J + 1; 817 Read_C_String (C.Lines, Buf); 818 819 if Buf (Buf'First) = 0 then 820 return "???"; 821 end if; 822 823 Dir_Idx := Read_LEB128 (C.Lines); 824 Mod_Time := Read_LEB128 (C.Lines); 825 Length := Read_LEB128 (C.Lines); 826 exit when J = Code; 827 end loop; 828 829 return To_String (Buf); 830 end To_File_Name; 831 832 ------------------------- 833 -- Read_Initial_Length -- 834 ------------------------- 835 836 procedure Read_Initial_Length 837 (S : in out Mapped_Stream; 838 Len : out Offset; 839 Is64 : out Boolean) 840 is 841 Len32 : uint32; 842 Len64 : uint64; 843 begin 844 Len32 := Read (S); 845 if Len32 < 16#ffff_fff0# then 846 Is64 := False; 847 Len := Offset (Len32); 848 elsif Len32 < 16#ffff_ffff# then 849 -- Invalid length 850 raise Constraint_Error; 851 else 852 Is64 := True; 853 Len64 := Read (S); 854 Len := Offset (Len64); 855 end if; 856 end Read_Initial_Length; 857 858 ------------------------- 859 -- Read_Section_Offset -- 860 ------------------------- 861 862 procedure Read_Section_Offset 863 (S : in out Mapped_Stream; 864 Len : out Offset; 865 Is64 : Boolean) 866 is 867 begin 868 if Is64 then 869 Len := Offset (uint64'(Read (S))); 870 else 871 Len := Offset (uint32'(Read (S))); 872 end if; 873 end Read_Section_Offset; 874 875 -------------------- 876 -- Aranges_Lookup -- 877 -------------------- 878 879 procedure Aranges_Lookup 880 (C : in out Dwarf_Context; 881 Addr : Storage_Offset; 882 Info_Offset : out Offset; 883 Success : out Boolean) 884 is 885 begin 886 Seek (C.Aranges, 0); 887 888 while Tell (C.Aranges) < Length (C.Aranges) loop 889 Read_Aranges_Header (C, Info_Offset, Success); 890 exit when not Success; 891 892 loop 893 declare 894 Start : Storage_Offset; 895 Len : Storage_Count; 896 begin 897 Read_Aranges_Entry (C, Start, Len); 898 exit when Start = 0 and Len = 0; 899 if Addr >= Start 900 and then Addr < Start + Len 901 then 902 Success := True; 903 return; 904 end if; 905 end; 906 end loop; 907 end loop; 908 Success := False; 909 end Aranges_Lookup; 910 911 --------------- 912 -- Skip_Form -- 913 --------------- 914 915 procedure Skip_Form 916 (S : in out Mapped_Stream; 917 Form : uint32; 918 Is64 : Boolean; 919 Ptr_Sz : uint8) 920 is 921 Skip : Offset; 922 begin 923 case Form is 924 when DW_FORM_addr => 925 Skip := Offset (Ptr_Sz); 926 when DW_FORM_block2 => 927 Skip := Offset (uint16'(Read (S))); 928 when DW_FORM_block4 => 929 Skip := Offset (uint32'(Read (S))); 930 when DW_FORM_data2 | DW_FORM_ref2 => 931 Skip := 2; 932 when DW_FORM_data4 | DW_FORM_ref4 => 933 Skip := 4; 934 when DW_FORM_data8 | DW_FORM_ref8 | DW_FORM_ref_sig8 => 935 Skip := 8; 936 when DW_FORM_string => 937 while uint8'(Read (S)) /= 0 loop 938 null; 939 end loop; 940 return; 941 when DW_FORM_block | DW_FORM_exprloc => 942 Skip := Offset (uint32'(Read_LEB128 (S))); 943 when DW_FORM_block1 | DW_FORM_ref1 => 944 Skip := Offset (uint8'(Read (S))); 945 when DW_FORM_data1 | DW_FORM_flag => 946 Skip := 1; 947 when DW_FORM_sdata => 948 declare 949 Val : constant int32 := Read_LEB128 (S); 950 pragma Unreferenced (Val); 951 begin 952 return; 953 end; 954 when DW_FORM_strp | DW_FORM_ref_addr | DW_FORM_sec_offset => 955 Skip := (if Is64 then 8 else 4); 956 when DW_FORM_udata | DW_FORM_ref_udata => 957 declare 958 Val : constant uint32 := Read_LEB128 (S); 959 pragma Unreferenced (Val); 960 begin 961 return; 962 end; 963 when DW_FORM_flag_present => 964 return; 965 when DW_FORM_indirect => 966 raise Constraint_Error; 967 when others => 968 raise Constraint_Error; 969 end case; 970 Seek (S, Tell (S) + Skip); 971 end Skip_Form; 972 973 ----------------- 974 -- Seek_Abbrev -- 975 ----------------- 976 977 procedure Seek_Abbrev 978 (C : in out Dwarf_Context; 979 Abbrev_Offset : Offset; 980 Abbrev_Num : uint32) 981 is 982 Num : uint32; 983 Abbrev : uint32; 984 Tag : uint32; 985 Has_Child : uint8; 986 pragma Unreferenced (Abbrev, Tag, Has_Child); 987 begin 988 Seek (C.Abbrev, Abbrev_Offset); 989 990 Num := 1; 991 992 loop 993 exit when Num = Abbrev_Num; 994 995 Abbrev := Read_LEB128 (C.Abbrev); 996 Tag := Read_LEB128 (C.Abbrev); 997 Has_Child := Read (C.Abbrev); 998 999 loop 1000 declare 1001 Name : constant uint32 := Read_LEB128 (C.Abbrev); 1002 Form : constant uint32 := Read_LEB128 (C.Abbrev); 1003 begin 1004 exit when Name = 0 and Form = 0; 1005 end; 1006 end loop; 1007 1008 Num := Num + 1; 1009 end loop; 1010 end Seek_Abbrev; 1011 1012 ----------------------- 1013 -- Debug_Info_Lookup -- 1014 ----------------------- 1015 1016 procedure Debug_Info_Lookup 1017 (C : in out Dwarf_Context; 1018 Info_Offset : Offset; 1019 Line_Offset : out Offset; 1020 Success : out Boolean) 1021 is 1022 Unit_Length : Offset; 1023 Is64 : Boolean; 1024 Version : uint16; 1025 Abbrev_Offset : Offset; 1026 Addr_Sz : uint8; 1027 Abbrev : uint32; 1028 Has_Child : uint8; 1029 pragma Unreferenced (Has_Child); 1030 begin 1031 Success := False; 1032 1033 Seek (C.Info, Info_Offset); 1034 1035 Read_Initial_Length (C.Info, Unit_Length, Is64); 1036 1037 Version := Read (C.Info); 1038 if Version not in 2 .. 4 then 1039 return; 1040 end if; 1041 1042 Read_Section_Offset (C.Info, Abbrev_Offset, Is64); 1043 1044 Addr_Sz := Read (C.Info); 1045 if Addr_Sz /= (Address'Size / SSU) then 1046 return; 1047 end if; 1048 1049 -- Read DIEs 1050 1051 loop 1052 Abbrev := Read_LEB128 (C.Info); 1053 exit when Abbrev /= 0; 1054 end loop; 1055 1056 -- Read abbrev table 1057 1058 Seek_Abbrev (C, Abbrev_Offset, Abbrev); 1059 1060 -- First ULEB128 is the abbrev code 1061 1062 if Read_LEB128 (C.Abbrev) /= Abbrev then 1063 -- Ill formed abbrev table 1064 return; 1065 end if; 1066 1067 -- Then the tag 1068 1069 if Read_LEB128 (C.Abbrev) /= uint32'(DW_TAG_Compile_Unit) then 1070 -- Expect compile unit 1071 return; 1072 end if; 1073 1074 -- Then the has child flag 1075 1076 Has_Child := Read (C.Abbrev); 1077 1078 loop 1079 declare 1080 Name : constant uint32 := Read_LEB128 (C.Abbrev); 1081 Form : constant uint32 := Read_LEB128 (C.Abbrev); 1082 begin 1083 exit when Name = 0 and Form = 0; 1084 if Name = DW_AT_Stmt_List then 1085 case Form is 1086 when DW_FORM_sec_offset => 1087 Read_Section_Offset (C.Info, Line_Offset, Is64); 1088 when DW_FORM_data4 => 1089 Line_Offset := Offset (uint32'(Read (C.Info))); 1090 when DW_FORM_data8 => 1091 Line_Offset := Offset (uint64'(Read (C.Info))); 1092 when others => 1093 -- Unhandled form 1094 return; 1095 end case; 1096 1097 Success := True; 1098 return; 1099 else 1100 Skip_Form (C.Info, Form, Is64, Addr_Sz); 1101 end if; 1102 end; 1103 end loop; 1104 1105 return; 1106 end Debug_Info_Lookup; 1107 1108 ------------------------- 1109 -- Read_Aranges_Header -- 1110 ------------------------- 1111 1112 procedure Read_Aranges_Header 1113 (C : in out Dwarf_Context; 1114 Info_Offset : out Offset; 1115 Success : out Boolean) 1116 is 1117 Unit_Length : Offset; 1118 Is64 : Boolean; 1119 Version : uint16; 1120 Sz : uint8; 1121 begin 1122 Success := False; 1123 1124 Read_Initial_Length (C.Aranges, Unit_Length, Is64); 1125 1126 Version := Read (C.Aranges); 1127 if Version /= 2 then 1128 return; 1129 end if; 1130 1131 Read_Section_Offset (C.Aranges, Info_Offset, Is64); 1132 1133 -- Read address_size (ubyte) 1134 1135 Sz := Read (C.Aranges); 1136 if Sz /= (Address'Size / SSU) then 1137 return; 1138 end if; 1139 1140 -- Read segment_size (ubyte) 1141 1142 Sz := Read (C.Aranges); 1143 if Sz /= 0 then 1144 return; 1145 end if; 1146 1147 -- Handle alignment on twice the address size 1148 declare 1149 Cur_Off : constant Offset := Tell (C.Aranges); 1150 Align : constant Offset := 2 * Address'Size / SSU; 1151 Space : constant Offset := Cur_Off mod Align; 1152 begin 1153 if Space /= 0 then 1154 Seek (C.Aranges, Cur_Off + Align - Space); 1155 end if; 1156 end; 1157 1158 Success := True; 1159 end Read_Aranges_Header; 1160 1161 ------------------------ 1162 -- Read_Aranges_Entry -- 1163 ------------------------ 1164 1165 procedure Read_Aranges_Entry 1166 (C : in out Dwarf_Context; 1167 Start : out Storage_Offset; 1168 Len : out Storage_Count) 1169 is 1170 begin 1171 -- Read table 1172 if Address'Size = 32 then 1173 declare 1174 S, L : uint32; 1175 begin 1176 S := Read (C.Aranges); 1177 L := Read (C.Aranges); 1178 Start := Storage_Offset (S); 1179 Len := Storage_Count (L); 1180 end; 1181 elsif Address'Size = 64 then 1182 declare 1183 S, L : uint64; 1184 begin 1185 S := Read (C.Aranges); 1186 L := Read (C.Aranges); 1187 Start := Storage_Offset (S); 1188 Len := Storage_Count (L); 1189 end; 1190 else 1191 raise Constraint_Error; 1192 end if; 1193 end Read_Aranges_Entry; 1194 1195 ------------------ 1196 -- Enable_Cache -- 1197 ------------------ 1198 1199 procedure Enable_Cache (C : in out Dwarf_Context) is 1200 Cache : Search_Array_Access; 1201 begin 1202 -- Phase 1: count number of symbols. Phase 2: fill the cache. 1203 declare 1204 S : Object_Symbol; 1205 Val : uint64; 1206 Xcode_Low : constant uint64 := uint64 (C.Low); 1207 Xcode_High : constant uint64 := uint64 (C.High); 1208 Sz : uint32; 1209 Addr, Prev_Addr : uint32; 1210 Nbr_Symbols : Natural; 1211 begin 1212 for Phase in 1 .. 2 loop 1213 Nbr_Symbols := 0; 1214 S := First_Symbol (C.Obj.all); 1215 Prev_Addr := uint32'Last; 1216 while S /= Null_Symbol loop 1217 -- Discard symbols of length 0 or located outside of the 1218 -- execution code section outer boundaries. 1219 Sz := uint32 (Size (S)); 1220 Val := Value (S); 1221 1222 if Sz > 0 1223 and then Val >= Xcode_Low 1224 and then Val <= Xcode_High 1225 then 1226 1227 Addr := uint32 (Val - Xcode_Low); 1228 1229 -- Try to filter symbols at the same address. This is a best 1230 -- effort as they might not be consecutive. 1231 if Addr /= Prev_Addr then 1232 Nbr_Symbols := Nbr_Symbols + 1; 1233 Prev_Addr := Addr; 1234 1235 if Phase = 2 then 1236 C.Cache (Nbr_Symbols) := 1237 (First => Addr, 1238 Size => Sz, 1239 Sym => uint32 (Off (S)), 1240 Line => 0); 1241 end if; 1242 end if; 1243 end if; 1244 1245 S := Next_Symbol (C.Obj.all, S); 1246 end loop; 1247 1248 if Phase = 1 then 1249 -- Allocate the cache 1250 Cache := new Search_Array (1 .. Nbr_Symbols); 1251 C.Cache := Cache; 1252 end if; 1253 end loop; 1254 pragma Assert (Nbr_Symbols = C.Cache'Last); 1255 end; 1256 1257 -- Sort the cache. 1258 Sort_Search_Array (C.Cache.all); 1259 1260 -- Set line offsets 1261 if not C.Has_Debug then 1262 return; 1263 end if; 1264 declare 1265 Info_Offset : Offset; 1266 Line_Offset : Offset; 1267 Success : Boolean; 1268 Ar_Start : Storage_Offset; 1269 Ar_Len : Storage_Count; 1270 Start, Len : uint32; 1271 First, Last : Natural; 1272 Mid : Natural; 1273 begin 1274 Seek (C.Aranges, 0); 1275 1276 while Tell (C.Aranges) < Length (C.Aranges) loop 1277 Read_Aranges_Header (C, Info_Offset, Success); 1278 exit when not Success; 1279 1280 Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); 1281 exit when not Success; 1282 1283 -- Read table 1284 loop 1285 Read_Aranges_Entry (C, Ar_Start, Ar_Len); 1286 exit when Ar_Start = 0 and Ar_Len = 0; 1287 1288 Len := uint32 (Ar_Len); 1289 Start := uint32 (Ar_Start - C.Low); 1290 1291 -- Search START in the array 1292 First := Cache'First; 1293 Last := Cache'Last; 1294 Mid := First; -- In case of array with one element 1295 while First < Last loop 1296 Mid := First + (Last - First) / 2; 1297 if Start < Cache (Mid).First then 1298 Last := Mid - 1; 1299 elsif Start >= Cache (Mid).First + Cache (Mid).Size then 1300 First := Mid + 1; 1301 else 1302 exit; 1303 end if; 1304 end loop; 1305 1306 -- Fill info. 1307 1308 -- There can be overlapping symbols 1309 while Mid > Cache'First 1310 and then Cache (Mid - 1).First <= Start 1311 and then Cache (Mid - 1).First + Cache (Mid - 1).Size > Start 1312 loop 1313 Mid := Mid - 1; 1314 end loop; 1315 while Mid <= Cache'Last loop 1316 if Start < Cache (Mid).First + Cache (Mid).Size 1317 and then Start + Len > Cache (Mid).First 1318 then 1319 -- MID is within the bounds 1320 Cache (Mid).Line := uint32 (Line_Offset); 1321 elsif Start + Len <= Cache (Mid).First then 1322 -- Over 1323 exit; 1324 end if; 1325 Mid := Mid + 1; 1326 end loop; 1327 end loop; 1328 end loop; 1329 end; 1330 end Enable_Cache; 1331 1332 ---------------------- 1333 -- Symbolic_Address -- 1334 ---------------------- 1335 1336 procedure Symbolic_Address 1337 (C : in out Dwarf_Context; 1338 Addr : Storage_Offset; 1339 Dir_Name : out Str_Access; 1340 File_Name : out Str_Access; 1341 Subprg_Name : out String_Ptr_Len; 1342 Line_Num : out Natural) 1343 is 1344 procedure Set_Result (Match : Line_Info_Registers); 1345 -- Set results using match 1346 1347 procedure Set_Result (Match : Line_Info_Registers) is 1348 Dir_Idx : uint32; 1349 J : uint32; 1350 1351 Mod_Time : uint32; 1352 pragma Unreferenced (Mod_Time); 1353 1354 Length : uint32; 1355 pragma Unreferenced (Length); 1356 1357 begin 1358 Seek (C.Lines, C.Prologue.File_Names_Offset); 1359 1360 -- Find the entry 1361 1362 J := 0; 1363 loop 1364 J := J + 1; 1365 File_Name := Read_C_String (C.Lines); 1366 1367 if File_Name (File_Name'First) = ASCII.NUL then 1368 -- End of file list, so incorrect entry 1369 return; 1370 end if; 1371 1372 Dir_Idx := Read_LEB128 (C.Lines); 1373 Mod_Time := Read_LEB128 (C.Lines); 1374 Length := Read_LEB128 (C.Lines); 1375 exit when J = Match.File; 1376 end loop; 1377 1378 if Dir_Idx = 0 then 1379 -- No directory 1380 Dir_Name := null; 1381 1382 else 1383 Seek (C.Lines, C.Prologue.Includes_Offset); 1384 1385 J := 0; 1386 loop 1387 J := J + 1; 1388 Dir_Name := Read_C_String (C.Lines); 1389 1390 if Dir_Name (Dir_Name'First) = ASCII.NUL then 1391 -- End of directory list, so ill-formed table 1392 return; 1393 end if; 1394 1395 exit when J = Dir_Idx; 1396 1397 end loop; 1398 end if; 1399 1400 Line_Num := Natural (Match.Line); 1401 end Set_Result; 1402 1403 Addr_Int : constant uint64 := uint64 (Addr); 1404 Previous_Row : Line_Info_Registers; 1405 Info_Offset : Offset; 1406 Line_Offset : Offset; 1407 Success : Boolean; 1408 Done : Boolean; 1409 S : Object_Symbol; 1410 begin 1411 -- Initialize result 1412 Dir_Name := null; 1413 File_Name := null; 1414 Subprg_Name := (null, 0); 1415 Line_Num := 0; 1416 1417 if C.Cache /= null then 1418 -- Look in the cache 1419 declare 1420 Addr_Off : constant uint32 := uint32 (Addr - C.Low); 1421 First, Last, Mid : Natural; 1422 begin 1423 First := C.Cache'First; 1424 Last := C.Cache'Last; 1425 while First <= Last loop 1426 Mid := First + (Last - First) / 2; 1427 if Addr_Off < C.Cache (Mid).First then 1428 Last := Mid - 1; 1429 elsif Addr_Off >= C.Cache (Mid).First + C.Cache (Mid).Size then 1430 First := Mid + 1; 1431 else 1432 exit; 1433 end if; 1434 end loop; 1435 if Addr_Off >= C.Cache (Mid).First 1436 and then Addr_Off < C.Cache (Mid).First + C.Cache (Mid).Size 1437 then 1438 Line_Offset := Offset (C.Cache (Mid).Line); 1439 S := Read_Symbol (C.Obj.all, Offset (C.Cache (Mid).Sym)); 1440 Subprg_Name := Object_Reader.Name (C.Obj.all, S); 1441 else 1442 -- Not found 1443 return; 1444 end if; 1445 end; 1446 else 1447 -- Search symbol 1448 S := First_Symbol (C.Obj.all); 1449 while S /= Null_Symbol loop 1450 if Spans (S, Addr_Int) then 1451 Subprg_Name := Object_Reader.Name (C.Obj.all, S); 1452 exit; 1453 end if; 1454 1455 S := Next_Symbol (C.Obj.all, S); 1456 end loop; 1457 1458 -- Search address in aranges table 1459 1460 Aranges_Lookup (C, Addr, Info_Offset, Success); 1461 if not Success then 1462 return; 1463 end if; 1464 1465 -- Search stmt_list in info table 1466 1467 Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); 1468 if not Success then 1469 return; 1470 end if; 1471 end if; 1472 1473 Seek (C.Lines, Line_Offset); 1474 C.Next_Prologue := 0; 1475 Initialize_State_Machine (C); 1476 Parse_Prologue (C); 1477 1478 -- Advance to the first entry 1479 1480 loop 1481 Read_And_Execute_Isn (C, Done); 1482 1483 if C.Registers.Is_Row then 1484 Previous_Row := C.Registers; 1485 exit; 1486 end if; 1487 1488 exit when Done; 1489 end loop; 1490 1491 -- Read the rest of the entries 1492 1493 while Tell (C.Lines) < C.Next_Prologue loop 1494 Read_And_Execute_Isn (C, Done); 1495 1496 if C.Registers.Is_Row then 1497 if not Previous_Row.End_Sequence 1498 and then Addr_Int >= Previous_Row.Address 1499 and then Addr_Int < C.Registers.Address 1500 then 1501 Set_Result (Previous_Row); 1502 return; 1503 1504 elsif Addr_Int = C.Registers.Address then 1505 Set_Result (C.Registers); 1506 return; 1507 end if; 1508 1509 Previous_Row := C.Registers; 1510 end if; 1511 1512 exit when Done; 1513 end loop; 1514 end Symbolic_Address; 1515 1516 ------------------- 1517 -- String_Length -- 1518 ------------------- 1519 1520 function String_Length (Str : Str_Access) return Natural is 1521 begin 1522 for I in Str'Range loop 1523 if Str (I) = ASCII.NUL then 1524 return I - Str'First; 1525 end if; 1526 end loop; 1527 return Str'Last; 1528 end String_Length; 1529 1530 ------------------------ 1531 -- Symbolic_Traceback -- 1532 ------------------------ 1533 1534 procedure Symbolic_Traceback 1535 (Cin : Dwarf_Context; 1536 Traceback : AET.Tracebacks_Array; 1537 Suppress_Hex : Boolean; 1538 Symbol_Found : in out Boolean; 1539 Res : in out System.Bounded_Strings.Bounded_String) 1540 is 1541 use Ada.Characters.Handling; 1542 C : Dwarf_Context := Cin; 1543 1544 Addr_In_Traceback : Address; 1545 Offset_To_Lookup : Storage_Offset; 1546 1547 Dir_Name : Str_Access; 1548 File_Name : Str_Access; 1549 Subprg_Name : String_Ptr_Len; 1550 Line_Num : Natural; 1551 Off : Natural; 1552 begin 1553 if not C.Has_Debug then 1554 Symbol_Found := False; 1555 return; 1556 else 1557 Symbol_Found := True; 1558 end if; 1559 1560 for J in Traceback'Range loop 1561 -- If the buffer is full, no need to do any useless work 1562 exit when Is_Full (Res); 1563 1564 Addr_In_Traceback := PC_For (Traceback (J)); 1565 1566 Offset_To_Lookup := Addr_In_Traceback - C.Load_Address; 1567 1568 Symbolic_Address 1569 (C, 1570 Offset_To_Lookup, 1571 Dir_Name, 1572 File_Name, 1573 Subprg_Name, 1574 Line_Num); 1575 1576 if File_Name /= null then 1577 declare 1578 Last : constant Natural := String_Length (File_Name); 1579 Is_Ada : constant Boolean := 1580 Last > 3 1581 and then 1582 To_Upper (String (File_Name (Last - 3 .. Last - 1))) = 1583 ".AD"; 1584 -- True if this is an Ada file. This doesn't take into account 1585 -- nonstandard file-naming conventions, but that's OK; this is 1586 -- purely cosmetic. It covers at least .ads, .adb, and .ada. 1587 1588 Line_Image : constant String := Natural'Image (Line_Num); 1589 begin 1590 if Subprg_Name.Len /= 0 then 1591 -- For Ada code, Symbol_Image is in all lower case; we don't 1592 -- have the case from the original source code. But the best 1593 -- guess is Mixed_Case, so convert to that. 1594 1595 if Is_Ada then 1596 declare 1597 Symbol_Image : String := 1598 Object_Reader.Decoded_Ada_Name 1599 (C.Obj.all, 1600 Subprg_Name); 1601 begin 1602 for K in Symbol_Image'Range loop 1603 if K = Symbol_Image'First 1604 or else not 1605 (Is_Letter (Symbol_Image (K - 1)) 1606 or else Is_Digit (Symbol_Image (K - 1))) 1607 then 1608 Symbol_Image (K) := To_Upper (Symbol_Image (K)); 1609 end if; 1610 end loop; 1611 Append (Res, Symbol_Image); 1612 end; 1613 else 1614 Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); 1615 1616 Append 1617 (Res, 1618 String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); 1619 end if; 1620 Append (Res, ' '); 1621 end if; 1622 1623 Append (Res, "at "); 1624 Append (Res, String (File_Name (1 .. Last))); 1625 Append (Res, ':'); 1626 Append (Res, Line_Image (2 .. Line_Image'Last)); 1627 end; 1628 else 1629 if Suppress_Hex then 1630 Append (Res, "..."); 1631 else 1632 Append_Address (Res, Addr_In_Traceback); 1633 end if; 1634 1635 if Subprg_Name.Len > 0 then 1636 Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); 1637 1638 Append (Res, ' '); 1639 Append (Res, String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); 1640 end if; 1641 1642 Append (Res, " at ???"); 1643 end if; 1644 1645 Append (Res, ASCII.LF); 1646 end loop; 1647 end Symbolic_Traceback; 1648end System.Dwarf_Lines; 1649