File : s-trasym-dwarf.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- S Y S T E M . T R A C E B A C K . S Y M B O L I C --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1999-2015, AdaCore --
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 -- Run-time symbolic traceback support for targets using DWARF debug data
33
34 pragma Polling (Off);
35 -- We must turn polling off for this unit, because otherwise we can get
36 -- elaboration circularities when polling is turned on.
37
38 with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
39
40 with System.Address_To_Access_Conversions;
41 with System.CRTL;
42 with System.Dwarf_Lines;
43 with System.Exception_Traces;
44 with System.Standard_Library;
45 with System.Storage_Elements;
46 with System.Traceback_Entries;
47
48 package body System.Traceback.Symbolic is
49
50 subtype Big_String is String (Positive);
51
52 function Value (Item : System.Address) return String;
53 -- Return the String contained in Item, up until the first NUL character
54
55 package Module_Name is
56
57 function Get (Addr : access System.Address) return String;
58 -- Returns the module name for the given address, Addr may be updated
59 -- to be set relative to a shared library. This depends on the platform.
60 -- Returns an empty string for the main executable.
61
62 function Is_Supported return Boolean;
63 pragma Inline (Is_Supported);
64 -- Returns True if Module_Name is supported, so if the traceback is
65 -- supported for shared libraries.
66
67 end Module_Name;
68
69 package body Module_Name is separate;
70
71 function Executable_Name return String;
72 -- Returns the executable name as reported by argv[0]. If gnat_argv not
73 -- initialized or if argv[0] executable not found in path, function returns
74 -- an empty string.
75
76 function Get_Executable_Load_Address return System.Address;
77 pragma Import (C, Get_Executable_Load_Address,
78 "__gnat_get_executable_load_address");
79 -- Get the load address of the executable, or Null_Address if not known
80
81 function Module_Symbolic_Traceback
82 (Module_Name : String;
83 Traceback : Tracebacks_Array;
84 Load_Address : System.Address;
85 Symbol_Found : in out Boolean) return String;
86 -- Returns the Traceback for a given module or an empty string if not in
87 -- a module. Parameter Load_Address is the load address of the module,
88 -- or Null_Address is not rebased. Symbol_Found is as for
89 -- Dwarf_Lines.Symbolic_Traceback.
90
91 function Multi_Module_Symbolic_Traceback
92 (Traceback : Tracebacks_Array;
93 Exec_Name : String;
94 Exec_Address : System.Address;
95 Symbol_Found : in out Boolean) return String;
96 -- Build string containing symbolic traceback for the given call chain,
97 -- using Exec_Name for the path of the executable and Exec_Address for its
98 -- load address. Symbol_Found is as for Dwarf_Lines.Symbolic_Traceback.
99
100 -----------------
101 -- Bounded_Str --
102 -----------------
103
104 -- Use our own verion of Bounded_Strings, to avoid depending on
105 -- Ada.Strings.Bounded.
106
107 type Bounded_Str (Max_Length : Natural) is limited record
108 Length : Natural := 0;
109 Chars : String (1 .. Max_Length);
110 end record;
111
112 procedure Append (X : in out Bounded_Str; C : Character);
113 procedure Append (X : in out Bounded_Str; S : String);
114 function To_String (X : Bounded_Str) return String;
115 function "+" (X : Bounded_Str) return String renames To_String;
116
117 Max_String_Length : constant := 4096;
118 -- Arbitrary limit on Bounded_Str length
119
120 procedure Append_Address
121 (Result : in out Bounded_Str;
122 A : Address);
123
124 ------------
125 -- Append --
126 ------------
127
128 procedure Append (X : in out Bounded_Str; C : Character) is
129 begin
130 -- If we have too many characters to fit, simply drop them
131
132 if X.Length < X.Max_Length then
133 X.Length := X.Length + 1;
134 X.Chars (X.Length) := C;
135 end if;
136 end Append;
137
138 procedure Append (X : in out Bounded_Str; S : String) is
139 begin
140 for C of S loop
141 Append (X, C);
142 end loop;
143 end Append;
144
145 --------------------
146 -- Append_Address --
147 --------------------
148
149 procedure Append_Address
150 (Result : in out Bounded_Str;
151 A : Address)
152 is
153 S : String (1 .. 18);
154 P : Natural;
155 use System.Storage_Elements;
156 N : Integer_Address;
157
158 H : constant array (Integer range 0 .. 15) of Character :=
159 "0123456789abcdef";
160 begin
161 P := S'Last;
162 N := To_Integer (A);
163 loop
164 S (P) := H (Integer (N mod 16));
165 P := P - 1;
166 N := N / 16;
167 exit when N = 0;
168 end loop;
169
170 S (P - 1) := '0';
171 S (P) := 'x';
172
173 Append (Result, S (P - 1 .. S'Last));
174 end Append_Address;
175
176 -----------
177 -- Value --
178 -----------
179
180 function Value (Item : System.Address) return String is
181 package Conv is new System.Address_To_Access_Conversions (Big_String);
182 begin
183 if Item /= Null_Address then
184 for J in Big_String'Range loop
185 if Conv.To_Pointer (Item) (J) = ASCII.NUL then
186 return Conv.To_Pointer (Item) (1 .. J - 1);
187 end if;
188 end loop;
189 end if;
190
191 return "";
192 end Value;
193
194 ---------------------
195 -- Executable_Name --
196 ---------------------
197
198 function Executable_Name return String is
199 -- We have to import gnat_argv as an Address to match the type of
200 -- gnat_argv in the binder generated file. Otherwise, we get spurious
201 -- warnings about type mismatch when LTO is turned on.
202
203 Gnat_Argv : System.Address;
204 pragma Import (C, Gnat_Argv, "gnat_argv");
205
206 type Argv_Array is array (0 .. 0) of System.Address;
207 package Conv is new System.Address_To_Access_Conversions (Argv_Array);
208
209 function locate_exec_on_path (A : System.Address) return System.Address;
210 pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path");
211
212 begin
213 if Gnat_Argv = Null_Address then
214 return "";
215 end if;
216
217 declare
218 Addr : constant System.Address :=
219 locate_exec_on_path (Conv.To_Pointer (Gnat_Argv) (0));
220 Result : constant String := Value (Addr);
221
222 begin
223 -- The buffer returned by locate_exec_on_path was allocated using
224 -- malloc, so we should use free to release the memory.
225
226 if Addr /= Null_Address then
227 System.CRTL.free (Addr);
228 end if;
229
230 return Result;
231 end;
232 end Executable_Name;
233
234 -------------------------------
235 -- Module_Symbolic_Traceback --
236 -------------------------------
237
238 function Module_Symbolic_Traceback
239 (Module_Name : String;
240 Traceback : Tracebacks_Array;
241 Load_Address : System.Address;
242 Symbol_Found : in out Boolean) return String
243 is
244 use System.Dwarf_Lines;
245 C : Dwarf_Context (In_Exception => True);
246
247 begin
248 Open (Module_Name, C);
249
250 -- If a module can't be opened just return an empty string, we
251 -- just cannot give more information in this case.
252
253 if not Is_Open (C) then
254 return "";
255 end if;
256
257 Set_Load_Address (C, Load_Address);
258
259 declare
260 Result : constant String :=
261 Dwarf_Lines.Symbolic_Traceback
262 (C, Traceback, Symbol_Found);
263
264 begin
265 Close (C);
266
267 if Symbolic.Module_Name.Is_Supported then
268 return '[' & Module_Name & ']' & ASCII.LF & Result;
269 else
270 return Result;
271 end if;
272 end;
273
274 -- We must not allow an unhandled exception here, since this function
275 -- may be installed as a decorator for all automatic exceptions.
276
277 exception
278 when others =>
279 return "";
280 end Module_Symbolic_Traceback;
281
282 -------------------------------------
283 -- Multi_Module_Symbolic_Traceback --
284 -------------------------------------
285
286 function Multi_Module_Symbolic_Traceback
287 (Traceback : Tracebacks_Array;
288 Exec_Name : String;
289 Exec_Address : System.Address;
290 Symbol_Found : in out Boolean) return String
291 is
292 TB : Tracebacks_Array (Traceback'Range);
293 -- A partial copy of the possibly relocated traceback addresses. These
294 -- addresses gets relocated for GNU/Linux shared library for example.
295 -- This gets done in the Get_Module_Name routine.
296
297 begin
298 if Traceback'Length = 0 then
299 return "";
300 end if;
301
302 declare
303 Addr : aliased System.Address := Traceback (Traceback'First);
304 M_Name : constant String := Module_Name.Get (Addr'Access);
305 Pos : Positive;
306
307 begin
308 -- Will symbolize the first address...
309
310 TB (TB'First) := Addr;
311
312 Pos := TB'First + 1;
313
314 -- ... and all addresses in the same module
315
316 Same_Module : loop
317 exit Same_Module when Pos > Traceback'Last;
318
319 -- Get address to check for corresponding module name
320
321 Addr := Traceback (Pos);
322
323 exit Same_Module when Module_Name.Get (Addr'Access) /= M_Name;
324
325 -- Copy the possibly relocated address into TB
326
327 TB (Pos) := Addr;
328
329 Pos := Pos + 1;
330 end loop Same_Module;
331
332 -- Symbolize the addresses in the same module, and do a recursive
333 -- call for the remaining addresses.
334
335 declare
336 Module_Name : constant String :=
337 (if M_Name = "" then Exec_Name else M_Name);
338 Load_Address : constant System.Address :=
339 (if M_Name = "" then Exec_Address else System.Null_Address);
340
341 begin
342 return
343 Module_Symbolic_Traceback
344 (Module_Name, TB (TB'First .. Pos - 1), Load_Address,
345 Symbol_Found) &
346 Multi_Module_Symbolic_Traceback
347 (Traceback (Pos .. Traceback'Last), Exec_Name, Exec_Address,
348 Symbol_Found);
349 end;
350 end;
351 end Multi_Module_Symbolic_Traceback;
352
353 function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
354 Exec_Path : constant String := Executable_Name;
355 Exec_Load : constant System.Address := Get_Executable_Load_Address;
356
357 Symbol_Found : Boolean := False;
358 -- This will be set to True if any call to
359 -- Dwarf_Lines.Symbolic_Traceback finds any symbols.
360
361 Result : constant String :=
362 (if Symbolic.Module_Name.Is_Supported then
363 Multi_Module_Symbolic_Traceback
364 (Traceback, Exec_Path, Exec_Load, Symbol_Found)
365 else
366 Module_Symbolic_Traceback
367 (Exec_Path, Traceback, Exec_Load, Symbol_Found));
368
369 begin
370 -- If symbols were found, use the symbolic traceback
371
372 if Symbol_Found then
373 return Result;
374
375 -- Otherwise (no symbols found), fall back to hexadecimal addresses
376
377 elsif Traceback'Length > 0 then
378 declare
379 Hex : Bounded_Str (Max_Length => Max_String_Length);
380 use System.Traceback_Entries;
381 begin
382 Append (Hex, "Call stack traceback locations:" & ASCII.LF);
383
384 for J in Traceback'Range loop
385 Append_Address (Hex, PC_For (Traceback (J)));
386
387 if J /= Traceback'Last then
388 Append (Hex, " ");
389 end if;
390 end loop;
391
392 return +Hex;
393 end;
394
395 else
396 return "";
397 end if;
398 end Symbolic_Traceback;
399
400 function Symbolic_Traceback
401 (E : Ada.Exceptions.Exception_Occurrence) return String
402 is
403 begin
404 return Symbolic_Traceback (Ada.Exceptions.Traceback.Tracebacks (E));
405 end Symbolic_Traceback;
406
407 ---------------
408 -- To_String --
409 ---------------
410
411 function To_String (X : Bounded_Str) return String is
412 begin
413 return X.Chars (1 .. X.Length);
414 end To_String;
415
416 use Standard_Library;
417
418 Exception_Tracebacks_Symbolic : Integer;
419 pragma Import (C, Exception_Tracebacks_Symbolic,
420 "__gl_exception_tracebacks_symbolic");
421 -- Boolean indicating whether symbolic tracebacks should be generated.
422
423 begin
424 -- If this version of this package is available, and the binder switch -Es
425 -- was given, then we want to use this as the decorator by default, and we
426 -- want to turn on tracing for Unhandled_Raise_In_Main. Note that the user
427 -- cannot have already set Exception_Trace, because the runtime library is
428 -- elaborated before user-defined code.
429
430 if Exception_Tracebacks_Symbolic /= 0 then
431 Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access);
432 pragma Assert (Exception_Trace = RM_Convention);
433 Exception_Trace := Unhandled_Raise_In_Main;
434 end if;
435 end System.Traceback.Symbolic;