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