File : s-dwalin.adb
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-2015, 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 -- --
19 -- --
20 -- --
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
32 pragma 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
36 with Ada.Characters.Handling;
37 with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
38 with Ada.Unchecked_Deallocation;
39
40 with Interfaces; use Interfaces;
41
42 with System; use System;
43 with System.Storage_Elements; use System.Storage_Elements;
44 with System.Address_Image;
45 with System.IO; use System.IO;
46 with System.Object_Reader; use System.Object_Reader;
47 with System.Traceback_Entries; use System.Traceback_Entries;
48
49 package body System.Dwarf_Lines is
50
51 -----------------
52 -- Bounded_Str --
53 -----------------
54
55 -- Use our own verion of Bounded_Strings, to avoid depending on
56 -- Ada.Strings.Bounded.
57
58 type Bounded_Str (Max_Length : Natural) is limited record
59 Length : Natural := 0;
60 Chars : String (1 .. Max_Length);
61 end record;
62
63 procedure Append (X : in out Bounded_Str; C : Character);
64 procedure Append (X : in out Bounded_Str; S : String);
65 function To_String (X : Bounded_Str) return String;
66 function "+" (X : Bounded_Str) return String renames To_String;
67
68 Max_String_Length : constant := 4096;
69 -- This is the maximum size of a traceback string before the output of
70 -- Symbolic_Traceback is truncated. This provides for about 50 lines of
71 -- 80 characters, which is plenty for all but the most pathological cases.
72
73 ---------------------------------
74 -- DWARF Parser Implementation --
75 ---------------------------------
76
77 procedure Initialize_Pass (C : in out Dwarf_Context);
78 -- Seek to the first byte of the first prologue and prepare to make a pass
79 -- over the line number entries.
80
81 procedure Initialize_State_Machine (C : in out Dwarf_Context);
82 -- Set all state machine registers to their specified initial values
83
84 procedure Parse_Prologue (C : in out Dwarf_Context);
85 -- Decode a DWARF statement program prologue
86
87 procedure Read_And_Execute_Isn
88 (C : in out Dwarf_Context;
89 Done : out Boolean);
90 -- Read an execute a statement program instruction
91
92 function Dir_Code_To_Offset
93 (C : Dwarf_Context;
94 Code : uint32) return Offset;
95 -- Convert a directory reference to the offset of a null terminated string.
96 -- Returns zero on failure.
97
98 function To_File_Name
99 (C : Dwarf_Context;
100 Code : uint32) return String;
101 -- Extract a file name from the prologue
102
103 function To_Dir_Name
104 (C : Dwarf_Context;
105 Code : uint32) return String;
106 -- Extract a directory name from the prologue
107
108 function File_Code_To_Offset
109 (C : Dwarf_Context;
110 Code : uint32) return Offset;
111 -- Convert a file reference to the offset of a null terminated string.
112 -- Returns zero on failure.
113
114 type Callback is access procedure (C : Dwarf_Context);
115 procedure For_Each_Row (C : out Dwarf_Context; F : Callback);
116 -- Traverse each .debug_line entry with a callback
117
118 procedure Dump_Row (C : Dwarf_Context);
119 -- Dump a single row
120
121 -----------------------
122 -- DWARF constants --
123 -----------------------
124
125 -- 6.2.5.2 Standard Opcodes
126
127 DW_LNS_copy : constant := 1;
128 DW_LNS_advance_pc : constant := 2;
129 DW_LNS_advance_line : constant := 3;
130 DW_LNS_set_file : constant := 4;
131 DW_LNS_set_column : constant := 5;
132 DW_LNS_negate_stmt : constant := 6;
133 DW_LNS_set_basic_block : constant := 7;
134 DW_LNS_const_add_pc : constant := 8;
135 DW_LNS_fixed_advance_pc : constant := 9;
136 DW_LNS_set_prologue_end : constant := 10;
137 DW_LNS_set_epilogue_begin : constant := 11;
138 DW_LNS_set_isa : constant := 12;
139
140 -- 6.2.5.3 Extended Opcodes
141
142 DW_LNE_end_sequence : constant := 1;
143 DW_LNE_set_address : constant := 2;
144 DW_LNE_define_file : constant := 3;
145
146 -- From the DWARF version 4 public review draft
147
148 DW_LNE_set_discriminator : constant := 4;
149
150 ------------
151 -- Append --
152 ------------
153
154 procedure Append (X : in out Bounded_Str; C : Character) is
155 begin
156 -- If we have too many characters to fit, simply drop them
157
158 if X.Length < X.Max_Length then
159 X.Length := X.Length + 1;
160 X.Chars (X.Length) := C;
161 end if;
162 end Append;
163
164 procedure Append (X : in out Bounded_Str; S : String) is
165 begin
166 for C of S loop
167 Append (X, C);
168 end loop;
169 end Append;
170
171 -----------
172 -- Close --
173 -----------
174
175 procedure Close (C : in out Dwarf_Context) is
176 procedure Unchecked_Deallocation is new
177 Ada.Unchecked_Deallocation (Object_File, Object_File_Access);
178 begin
179 Close (C.Obj.all);
180 Unchecked_Deallocation (C.Obj);
181 end Close;
182
183 ------------------------
184 -- Dir_Code_To_Offset --
185 ------------------------
186
187 function Dir_Code_To_Offset
188 (C : Dwarf_Context;
189 Code : uint32) return Offset
190 is
191 Saved_Off : Offset;
192 Off : Offset;
193 Buf : Buffer;
194 J : uint32;
195
196 Dummy : uint32;
197
198 begin
199 Tell (C.Obj.all, Saved_Off);
200 Seek (C.Obj.all, C.Prologue.Includes_Offset);
201
202 J := 0;
203 loop
204 J := J + 1;
205 Tell (C.Obj.all, Off);
206 Read_C_String (C.Obj.all, Buf);
207
208 if Strlen (Buf) = 0 then
209 Seek (C.Obj.all, Saved_Off);
210 return 0;
211 end if;
212
213 exit when J = Code;
214 end loop;
215
216 Seek (C.Obj.all, Saved_Off);
217 return Off;
218 end Dir_Code_To_Offset;
219
220 ----------
221 -- Dump --
222 ----------
223
224 procedure Dump (C : in out Dwarf_Context) is
225 begin
226 For_Each_Row (C, Dump_Row'Access);
227 end Dump;
228
229 --------------
230 -- Dump_Row --
231 --------------
232
233 procedure Dump_Row (C : Dwarf_Context) is
234 PC : constant Integer_Address := Integer_Address (C.Registers.Address);
235
236 begin
237 Put (System.Address_Image (To_Address (PC)));
238 Put (" ");
239 Put (To_File_Name (C, C.Registers.File));
240 Put (":");
241
242 declare
243 Image : constant String := uint32'Image (C.Registers.Line);
244 begin
245 Put_Line (Image (2 .. Image'Last));
246 end;
247
248 end Dump_Row;
249
250 -------------------------
251 -- File_Code_To_Offset --
252 -------------------------
253
254 function File_Code_To_Offset
255 (C : Dwarf_Context;
256 Code : uint32) return Offset
257 is
258 Off : Offset;
259 Saved_Off : Offset;
260 Buf : Buffer;
261 J : uint32;
262
263 Dummy : uint32;
264
265 begin
266 Tell (C.Obj.all, Saved_Off);
267 Seek (C.Obj.all, C.Prologue.File_Names_Offset);
268
269 J := 0;
270 loop
271 J := J + 1;
272 Tell (C.Obj.all, Off);
273 Read_C_String (C.Obj.all, Buf);
274
275 if Strlen (Buf) = 0 then
276 Seek (C.Obj.all, Saved_Off);
277 return 0;
278 end if;
279
280 Dummy := Read_LEB128 (C.Obj.all);
281 Dummy := Read_LEB128 (C.Obj.all);
282 Dummy := Read_LEB128 (C.Obj.all);
283 exit when J = Code;
284 end loop;
285
286 Seek (C.Obj.all, Saved_Off);
287 return Off;
288 end File_Code_To_Offset;
289
290 ------------------
291 -- For_Each_Row --
292 ------------------
293
294 procedure For_Each_Row (C : out Dwarf_Context; F : Callback) is
295 Done : Boolean;
296
297 begin
298 Initialize_Pass (C);
299
300 loop
301 Read_And_Execute_Isn (C, Done);
302
303 if C.Registers.Is_Row then
304 F.all (C);
305 end if;
306
307 exit when Done;
308 end loop;
309 end For_Each_Row;
310
311 ---------------------
312 -- Initialize_Pass --
313 ---------------------
314
315 procedure Initialize_Pass (C : in out Dwarf_Context) is
316 Sec : Object_Section;
317
318 begin
319 if Format (C.Obj.all) = XCOFF32 then
320 Sec := Get_Section (C.Obj.all, ".dwline");
321 else
322 Sec := Get_Section (C.Obj.all, ".debug_line");
323 end if;
324
325 if Sec = Null_Section and then C.In_Exception then
326 C.Valid := False;
327
328 else
329 C.Valid := True;
330
331 C.Next_Prologue := Off (Sec);
332 C.End_Of_Section := Off (Sec) + Offset (Size (Sec)) - 1;
333 Seek (C.Obj.all, C.Next_Prologue);
334 Initialize_State_Machine (C);
335 end if;
336 end Initialize_Pass;
337
338 ------------------------------
339 -- Initialize_State_Machine --
340 ------------------------------
341
342 procedure Initialize_State_Machine (C : in out Dwarf_Context) is
343 begin
344 C.Registers :=
345 (Address => 0,
346 File => 1,
347 Line => 1,
348 Column => 0,
349 Is_Stmt => C.Prologue.Default_Is_Stmt = 0,
350 Basic_Block => False,
351 End_Sequence => False,
352 Prologue_End => False,
353 Epilogue_Begin => False,
354 ISA => 0,
355 Is_Row => False);
356 end Initialize_State_Machine;
357
358 -------------
359 -- Is_Open --
360 -------------
361
362 function Is_Open (C : Dwarf_Context) return Boolean is
363 begin
364 return C.Obj /= null;
365 end Is_Open;
366
367 ----------
368 -- Open --
369 ----------
370
371 procedure Open (File_Name : String; C : in out Dwarf_Context) is
372 begin
373 C.Obj := Open (File_Name, C.In_Exception);
374 end Open;
375
376 --------------------
377 -- Parse_Prologue --
378 --------------------
379
380 procedure Parse_Prologue (C : in out Dwarf_Context) is
381 Char : uint8;
382 Prev : uint8;
383 -- The most recently read character and the one preceding it
384
385 Dummy : uint32;
386 -- Destination for reads we don't care about
387
388 Buf : Buffer;
389 Off : Offset;
390
391 First_Byte_Of_Prologue : Offset;
392 Last_Byte_Of_Prologue : Offset;
393
394 Max_Op_Per_Insn : uint8;
395 pragma Unreferenced (Max_Op_Per_Insn);
396
397 Obj : Object_File renames C.Obj.all;
398 Prologue : Line_Info_Prologue renames C.Prologue;
399
400 begin
401 Tell (Obj, First_Byte_Of_Prologue);
402 Prologue.Unit_Length := Read (Obj);
403 Tell (Obj, Off);
404 C.Next_Prologue := Off + Offset (Prologue.Unit_Length);
405
406 Prologue.Version := Read (Obj);
407 Prologue.Prologue_Length := Read (Obj);
408 Tell (Obj, Last_Byte_Of_Prologue);
409 Last_Byte_Of_Prologue :=
410 Last_Byte_Of_Prologue + Offset (Prologue.Prologue_Length) - 1;
411
412 Prologue.Min_Isn_Length := Read (Obj);
413
414 if Prologue.Version >= 4 then
415 Max_Op_Per_Insn := Read (Obj);
416 end if;
417
418 Prologue.Default_Is_Stmt := Read (Obj);
419 Prologue.Line_Base := Read (Obj);
420 Prologue.Line_Range := Read (Obj);
421 Prologue.Opcode_Base := Read (Obj);
422
423 -- Opcode_Lengths is an array of Opcode_Base bytes specifying the
424 -- number of LEB128 operands for each of the standard opcodes.
425
426 for J in 1 .. uint32 (Prologue.Opcode_Base - 1) loop
427 Prologue.Opcode_Lengths (J) := Read (Obj);
428 end loop;
429
430 -- The include directories table follows. This is a list of null
431 -- terminated strings terminated by a double null. We only store
432 -- its offset for later decoding.
433
434 Tell (Obj, Prologue.Includes_Offset);
435 Char := Read (Obj);
436
437 if Char /= 0 then
438 loop
439 Prev := Char;
440 Char := Read (Obj);
441 exit when Char = 0 and Prev = 0;
442 end loop;
443 end if;
444
445 -- The file_names table is next. Each record is a null terminated string
446 -- for the file name, an unsigned LEB128 directory index, an unsigned
447 -- LEB128 modification time, and an LEB128 file length. The table is
448 -- terminated by a null byte.
449
450 Tell (Obj, Prologue.File_Names_Offset);
451
452 loop
453 -- Read the filename
454
455 Read_C_String (Obj, Buf);
456 exit when Buf (0) = 0;
457 Dummy := Read_LEB128 (Obj); -- Skip the directory index.
458 Dummy := Read_LEB128 (Obj); -- Skip the modification time.
459 Dummy := Read_LEB128 (Obj); -- Skip the file length.
460 end loop;
461
462 -- Check we're where we think we are. This sanity check ensures we think
463 -- the prologue ends where the prologue says it does. It we aren't then
464 -- we've probably gotten out of sync somewhere.
465
466 Tell (Obj, Off);
467
468 if Prologue.Unit_Length /= 0
469 and then Off /= Last_Byte_Of_Prologue + 1
470 then
471 raise Dwarf_Error with "Parse error reading DWARF information";
472 end if;
473 end Parse_Prologue;
474
475 --------------------------
476 -- Read_And_Execute_Isn --
477 --------------------------
478
479 procedure Read_And_Execute_Isn
480 (C : in out Dwarf_Context;
481 Done : out Boolean)
482 is
483 Opcode : uint8;
484 Extended_Opcode : uint8;
485 uint32_Operand : uint32;
486 int32_Operand : int32;
487 uint16_Operand : uint16;
488 Off : Offset;
489
490 Extended_Length : uint32;
491 pragma Unreferenced (Extended_Length);
492
493 Obj : Object_File renames C.Obj.all;
494 Registers : Line_Info_Registers renames C.Registers;
495 Prologue : Line_Info_Prologue renames C.Prologue;
496
497 begin
498 Done := False;
499 Registers.Is_Row := False;
500
501 if Registers.End_Sequence then
502 Initialize_State_Machine (C);
503 end if;
504
505 -- Read the next prologue
506
507 Tell (Obj, Off);
508 while Off = C.Next_Prologue loop
509 Initialize_State_Machine (C);
510 Parse_Prologue (C);
511 Tell (Obj, Off);
512 exit when Off + 3 >= C.End_Of_Section;
513 end loop;
514
515 -- Test whether we're done
516
517 Tell (Obj, Off);
518
519 -- We are finished when we either reach the end of the section,
520 -- or we have reached zero padding at the end of the section.
521
522 if Prologue.Unit_Length = 0 or else Off + 3 >= C.End_Of_Section then
523 Done := True;
524 return;
525 end if;
526
527 -- Read and interpret an instruction
528
529 Opcode := Read (Obj);
530
531 -- Extended opcodes
532
533 if Opcode = 0 then
534 Extended_Length := Read_LEB128 (Obj);
535 Extended_Opcode := Read (Obj);
536
537 case Extended_Opcode is
538 when DW_LNE_end_sequence =>
539
540 -- Mark the end of a sequence of source locations
541
542 Registers.End_Sequence := True;
543 Registers.Is_Row := True;
544
545 when DW_LNE_set_address =>
546
547 -- Set the program counter to a word
548
549 Registers.Address := Read_Address (Obj);
550
551 when DW_LNE_define_file =>
552
553 -- Not implemented
554
555 raise Dwarf_Error with "DWARF operator not implemented";
556
557 when DW_LNE_set_discriminator =>
558
559 -- Ignored
560
561 int32_Operand := Read_LEB128 (Obj);
562
563 when others =>
564
565 -- Fail on an unrecognized opcode
566
567 raise Dwarf_Error with "DWARF operator not implemented";
568 end case;
569
570 -- Standard opcodes
571
572 elsif Opcode < Prologue.Opcode_Base then
573 case Opcode is
574
575 -- Append a row to the line info matrix
576
577 when DW_LNS_copy =>
578 Registers.Basic_Block := False;
579 Registers.Is_Row := True;
580
581 -- Add an unsigned word to the program counter
582
583 when DW_LNS_advance_pc =>
584 uint32_Operand := Read_LEB128 (Obj);
585 Registers.Address :=
586 Registers.Address +
587 uint64 (uint32_Operand *
588 uint32 (Prologue.Min_Isn_Length));
589
590 -- Add a signed word to the current source line
591
592 when DW_LNS_advance_line =>
593 int32_Operand := Read_LEB128 (Obj);
594 Registers.Line :=
595 uint32 (int32 (Registers.Line) + int32_Operand);
596
597 -- Set the current source file
598
599 when DW_LNS_set_file =>
600 uint32_Operand := Read_LEB128 (Obj);
601 Registers.File := uint32_Operand;
602
603 -- Set the current source column
604
605 when DW_LNS_set_column =>
606 uint32_Operand := Read_LEB128 (Obj);
607 Registers.Column := uint32_Operand;
608
609 -- Toggle the "is statement" flag. GCC doesn't seem to set this???
610
611 when DW_LNS_negate_stmt =>
612 Registers.Is_Stmt := not Registers.Is_Stmt;
613
614 -- Mark the beginning of a basic block
615
616 when DW_LNS_set_basic_block =>
617 Registers.Basic_Block := True;
618
619 -- Advance the program counter as by the special opcode 255
620
621 when DW_LNS_const_add_pc =>
622 Registers.Address :=
623 Registers.Address +
624 uint64
625 (((255 - Prologue.Opcode_Base) / Prologue.Line_Range) *
626 Prologue.Min_Isn_Length);
627
628 -- Advance the program counter by a constant
629
630 when DW_LNS_fixed_advance_pc =>
631 uint16_Operand := Read (Obj);
632 Registers.Address :=
633 Registers.Address + uint64 (uint16_Operand);
634
635 -- The following are not implemented and ignored
636
637 when DW_LNS_set_prologue_end =>
638 null;
639
640 when DW_LNS_set_epilogue_begin =>
641 null;
642
643 when DW_LNS_set_isa =>
644 null;
645
646 -- Anything else is an error
647
648 when others =>
649 raise Dwarf_Error with "DWARF operator not implemented";
650 end case;
651
652 -- Decode a special opcode. This is a line and address increment encoded
653 -- in a single byte 'special opcode' as described in 6.2.5.1.
654
655 else
656 declare
657 Address_Increment : int32;
658 Line_Increment : int32;
659
660 begin
661 Opcode := Opcode - Prologue.Opcode_Base;
662
663 -- The adjusted opcode is a uint8 encoding an address increment
664 -- and a signed line increment. The upperbound is allowed to be
665 -- greater than int8'last so we decode using int32 directly to
666 -- prevent overflows.
667
668 Address_Increment :=
669 int32 (Opcode / Prologue.Line_Range) *
670 int32 (Prologue.Min_Isn_Length);
671 Line_Increment :=
672 int32 (Prologue.Line_Base) +
673 int32 (Opcode mod Prologue.Line_Range);
674
675 Registers.Address :=
676 Registers.Address + uint64 (Address_Increment);
677 Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment);
678 Registers.Basic_Block := False;
679 Registers.Prologue_End := False;
680 Registers.Epilogue_Begin := False;
681 Registers.Is_Row := True;
682 end;
683 end if;
684
685 exception
686 when Dwarf_Error =>
687
688 -- In case of errors during parse, just stop reading
689
690 Registers.Is_Row := False;
691 Done := True;
692 end Read_And_Execute_Isn;
693
694 ----------------------
695 -- Set_Load_Address --
696 ----------------------
697
698 procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is
699 begin
700 if Addr = Null_Address then
701 return;
702 else
703 C.Load_Slide :=
704 To_Integer (Addr) - Integer_Address (Get_Load_Address (C.Obj.all));
705 end if;
706 end Set_Load_Address;
707
708 ------------------------
709 -- Symbolic_Traceback --
710 ------------------------
711
712 function Symbolic_Traceback
713 (Cin : Dwarf_Context;
714 Traceback : Tracebacks_Array;
715 Symbol_Found : in out Boolean) return String
716 is
717 Done : Boolean;
718 Previous_Row : Line_Info_Registers;
719 C : Dwarf_Context := Cin;
720 Result : Bounded_Str (Max_Length => Max_String_Length);
721
722 -- Tables of matches for the passed array of addresses
723
724 File_Names : array (Traceback'Range) of Offset := (others => 0);
725 Lines : array (Traceback'Range) of uint32 := (others => 0);
726 Matched : array (Traceback'Range) of Boolean := (others => False);
727 Symbols : array (Traceback'Range) of Object_Symbol;
728
729 procedure Append (Match : Line_Info_Registers; Idx : Integer);
730 -- Add an entry to the matched address list
731
732 procedure Build_Return_String;
733 -- Construct a human readable string to return to the caller
734
735 procedure Match_And_Collect;
736 -- Check whether the current address is one the caller is interested in
737 -- and if so collect it for output.
738
739 procedure Find_Corresponding_Symbols;
740 -- Iterate over each symbol in the symbol table, and for each address in
741 -- the traceback try to populate Symbols.
742
743 ------------
744 -- Append --
745 ------------
746
747 procedure Append (Match : Line_Info_Registers; Idx : Integer) is
748 begin
749 Symbol_Found := True;
750 Matched (Idx) := True;
751 File_Names (Idx) := File_Code_To_Offset (C, Match.File);
752 Lines (Idx) := Match.Line;
753 end Append;
754
755 -------------------------
756 -- Build_Return_String --
757 -------------------------
758
759 procedure Build_Return_String is
760 begin
761
762 -- Append a line for each traceback entry
763
764 for J in Traceback'Range loop
765 declare
766 use Ada.Characters.Handling;
767
768 File_Image : constant String :=
769 Offset_To_String (C.Obj.all, File_Names (J));
770
771 Last : constant Natural := File_Image'Last;
772 Is_Ada : constant Boolean :=
773 File_Image'Length > 4 and then
774 To_Upper (File_Image (Last - 3 .. Last - 1)) = ".AD";
775 -- True if this is an Ada file. This doesn't take into account
776 -- nonstandard file-naming conventions, but that's OK; this is
777 -- purely cosmetic. It covers at least .ads, .adb, and .ada.
778
779 Symbol_Image : String :=
780 System.Object_Reader.Decoded_Ada_Name
781 (C.Obj.all, Symbols (J));
782
783 Line_Image : constant String :=
784 uint32'Image (Lines (J));
785
786 begin
787 if Matched (J) then
788 if Symbols (J) /= Null_Symbol then
789 -- For Ada code, Symbol_Image is in all lower case; we
790 -- don't have the case from the original source code.
791 -- But the best guess is Mixed_Case, so convert to that.
792
793 if Is_Ada then
794 for K in Symbol_Image'Range loop
795 if K = Symbol_Image'First or else
796 not (Is_Letter (Symbol_Image (K - 1))
797 or else Is_Digit (Symbol_Image (K - 1)))
798 then
799 Symbol_Image (K) := To_Upper (Symbol_Image (K));
800 end if;
801 end loop;
802 end if;
803
804 Append (Result, Symbol_Image);
805 Append (Result, " ");
806 end if;
807
808 Append (Result, "at ");
809 Append (Result, File_Image);
810 Append (Result, ":");
811 Append (Result, Line_Image (2 .. Line_Image'Last));
812
813 else
814 declare
815 Address_Image : constant String :=
816 "0x" & System.Address_Image (PC_For (Traceback (J)));
817 begin
818 Append (Result, Address_Image);
819 end;
820
821 Append (Result, " at ???");
822 end if;
823 end;
824
825 Append (Result, ASCII.LF);
826 end loop;
827 end Build_Return_String;
828
829 --------------------------------
830 -- Find_Corresponding_Symbols --
831 --------------------------------
832
833 procedure Find_Corresponding_Symbols is
834 S : Object_Symbol;
835
836 begin
837 S := First_Symbol (C.Obj.all);
838 while S /= Null_Symbol loop
839 for J in Traceback'Range loop
840 if Spans (S, uint64 (PC_For (Traceback (J)))) then
841 Symbols (J) := S;
842 end if;
843 end loop;
844
845 S := Next_Symbol (C.Obj.all, S);
846 end loop;
847 end Find_Corresponding_Symbols;
848
849 -----------------------
850 -- Match_And_Collect --
851 -----------------------
852
853 procedure Match_And_Collect is
854 Addr : Integer_Address;
855
856 begin
857 for J in Traceback'Range loop
858 Addr := To_Integer (PC_For (Traceback (J))) + C.Load_Slide;
859
860 if not Previous_Row.End_Sequence
861 and then Addr >= Integer_Address (Previous_Row.Address)
862 and then Addr < Integer_Address (C.Registers.Address)
863 then
864 Append (Previous_Row, J);
865
866 elsif Addr = Integer_Address (C.Registers.Address) then
867 Append (C.Registers, J);
868 end if;
869 end loop;
870 end Match_And_Collect;
871
872 -- Start of processing for Symbolic_Traceback
873
874 begin
875 Initialize_Pass (C);
876
877 if not C.Valid then
878
879 -- In this case just return an empty information. The module we
880 -- have opened is either in a non supported format or the debug
881 -- information is missing.
882
883 return "";
884 end if;
885
886 -- Advance to the first entry
887
888 loop
889 Read_And_Execute_Isn (C, Done);
890
891 if C.Registers.Is_Row then
892 Previous_Row := C.Registers;
893 exit;
894 end if;
895
896 exit when Done;
897 end loop;
898
899 -- Read the rest of the entries
900
901 loop
902 Read_And_Execute_Isn (C, Done);
903
904 if C.Registers.Is_Row then
905 Match_And_Collect;
906 Previous_Row := C.Registers;
907 end if;
908
909 exit when Done;
910 end loop;
911
912 -- Find the symbols covering the addresses in the traceback
913
914 Find_Corresponding_Symbols;
915
916 Build_Return_String;
917
918 return +Result;
919 end Symbolic_Traceback;
920
921 -----------------
922 -- To_Dir_Name --
923 -----------------
924
925 function To_Dir_Name
926 (C : Dwarf_Context;
927 Code : uint32) return String
928 is
929 Old_Off : Offset;
930 Off : Offset;
931
932 begin
933 if Code = 0 then
934 return "";
935 end if;
936
937 Tell (C.Obj.all, Old_Off);
938 Off := Dir_Code_To_Offset (C, Code);
939 Seek (C.Obj.all, Old_Off);
940 return Offset_To_String (C.Obj.all, Off);
941 end To_Dir_Name;
942
943 ------------------
944 -- To_File_Name --
945 ------------------
946
947 function To_File_Name
948 (C : Dwarf_Context;
949 Code : uint32) return String
950 is
951 Old_Off : Offset;
952 Off : Offset;
953 Buf : Buffer;
954 Dir_Idx : uint32;
955 J : uint32;
956
957 Mod_Time : uint32;
958 pragma Unreferenced (Mod_Time);
959
960 Length : uint32;
961 pragma Unreferenced (Length);
962
963 begin
964 Tell (C.Obj.all, Old_Off);
965 Seek (C.Obj.all, C.Prologue.File_Names_Offset);
966
967 -- Find the entry
968
969 J := 0;
970 loop
971 J := J + 1;
972 Tell (C.Obj.all, Off);
973 Read_C_String (C.Obj.all, Buf);
974
975 if Strlen (Buf) = 0 then
976 return "???";
977 end if;
978
979 Dir_Idx := Read_LEB128 (C.Obj.all);
980 Mod_Time := Read_LEB128 (C.Obj.all);
981 Length := Read_LEB128 (C.Obj.all);
982 exit when J = Code;
983 end loop;
984
985 Seek (C.Obj.all, Old_Off);
986
987 declare
988 Path : constant String := To_Dir_Name (C, Dir_Idx);
989 begin
990 if Path'Length > 0 then
991 return Path & "/" & To_String (Buf);
992 else
993 return To_String (Buf);
994 end if;
995 end;
996 end To_File_Name;
997
998 ---------------
999 -- To_String --
1000 ---------------
1001
1002 function To_String (X : Bounded_Str) return String is
1003 begin
1004 return X.Chars (1 .. X.Length);
1005 end To_String;
1006
1007 end System.Dwarf_Lines;