|
111
|
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 -- --
|
|
131
|
9 -- Copyright (C) 1999-2018, AdaCore --
|
|
111
|
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 -- 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.Unchecked_Deallocation;
|
|
|
39
|
|
|
40 with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
|
|
|
41 with Ada.Containers.Generic_Array_Sort;
|
|
|
42
|
|
|
43 with System.Address_To_Access_Conversions;
|
|
|
44 with System.Soft_Links;
|
|
|
45 with System.CRTL;
|
|
|
46 with System.Dwarf_Lines;
|
|
|
47 with System.Exception_Traces;
|
|
|
48 with System.Standard_Library;
|
|
|
49 with System.Traceback_Entries;
|
|
|
50 with System.Strings;
|
|
|
51 with System.Bounded_Strings;
|
|
|
52
|
|
|
53 package body System.Traceback.Symbolic is
|
|
|
54
|
|
|
55 use System.Bounded_Strings;
|
|
|
56 use System.Dwarf_Lines;
|
|
|
57
|
|
|
58 subtype Big_String is String (Positive);
|
|
|
59 -- To deal with C strings
|
|
|
60
|
|
|
61 package Big_String_Conv is new System.Address_To_Access_Conversions
|
|
|
62 (Big_String);
|
|
|
63
|
|
|
64 type Module_Cache;
|
|
|
65 type Module_Cache_Acc is access all Module_Cache;
|
|
|
66
|
|
|
67 type Module_Cache is record
|
|
|
68 Name : Strings.String_Access;
|
|
|
69 -- Name of the module
|
|
|
70
|
|
|
71 C : Dwarf_Context (In_Exception => True);
|
|
|
72 -- Context to symbolize an address within this module
|
|
|
73
|
|
|
74 Chain : Module_Cache_Acc;
|
|
|
75 end record;
|
|
|
76
|
|
|
77 procedure Free is new Ada.Unchecked_Deallocation
|
|
|
78 (Module_Cache,
|
|
|
79 Module_Cache_Acc);
|
|
|
80
|
|
|
81 Cache_Chain : Module_Cache_Acc;
|
|
|
82 -- Simply linked list of modules
|
|
|
83
|
|
|
84 type Module_Array is array (Natural range <>) of Module_Cache_Acc;
|
|
|
85 type Module_Array_Acc is access Module_Array;
|
|
|
86
|
|
|
87 Modules_Cache : Module_Array_Acc;
|
|
|
88 -- Sorted array of cached modules (if not null)
|
|
|
89
|
|
|
90 Exec_Module : aliased Module_Cache;
|
|
|
91 -- Context for the executable
|
|
|
92
|
|
|
93 type Init_State is (Uninitialized, Initialized, Failed);
|
|
|
94 Exec_Module_State : Init_State := Uninitialized;
|
|
|
95 -- How Exec_Module is initialized
|
|
|
96
|
|
|
97 procedure Init_Exec_Module;
|
|
|
98 -- Initialize Exec_Module if not already initialized
|
|
|
99
|
|
|
100 function Symbolic_Traceback
|
|
|
101 (Traceback : System.Traceback_Entries.Tracebacks_Array;
|
|
|
102 Suppress_Hex : Boolean) return String;
|
|
|
103 function Symbolic_Traceback
|
|
|
104 (E : Ada.Exceptions.Exception_Occurrence;
|
|
|
105 Suppress_Hex : Boolean) return String;
|
|
|
106 -- Suppress_Hex means do not print any hexadecimal addresses, even if the
|
|
|
107 -- symbol is not available.
|
|
|
108
|
|
|
109 function Lt (Left, Right : Module_Cache_Acc) return Boolean;
|
|
|
110 -- Sort function for Module_Cache
|
|
|
111
|
|
|
112 procedure Init_Module
|
|
|
113 (Module : out Module_Cache;
|
|
|
114 Success : out Boolean;
|
|
|
115 Module_Name : String;
|
|
|
116 Load_Address : Address := Null_Address);
|
|
|
117 -- Initialize Module
|
|
|
118
|
|
|
119 procedure Close_Module (Module : in out Module_Cache);
|
|
|
120 -- Finalize Module
|
|
|
121
|
|
|
122 function Value (Item : System.Address) return String;
|
|
|
123 -- Return the String contained in Item, up until the first NUL character
|
|
|
124
|
|
|
125 pragma Warnings (Off, "*Add_Module_To_Cache*");
|
|
131
|
126 procedure Add_Module_To_Cache (Module_Name : String;
|
|
|
127 Load_Address : System.Address);
|
|
111
|
128 -- To be called by Build_Cache_For_All_Modules to add a new module to the
|
|
|
129 -- list. May not be referenced.
|
|
|
130
|
|
|
131 package Module_Name is
|
|
|
132
|
|
|
133 procedure Build_Cache_For_All_Modules;
|
|
|
134 -- Create the cache for all current modules
|
|
|
135
|
|
131
|
136 function Get (Addr : System.Address;
|
|
|
137 Load_Addr : access System.Address) return String;
|
|
|
138 -- Returns the module name for the given address Addr, or an empty
|
|
|
139 -- string for the main executable. Load_Addr is set to the shared
|
|
|
140 -- library load address if this information is available, or to
|
|
|
141 -- System.Null_Address otherwise.
|
|
111
|
142
|
|
|
143 function Is_Supported return Boolean;
|
|
|
144 pragma Inline (Is_Supported);
|
|
|
145 -- Returns True if Module_Name is supported, so if the traceback is
|
|
|
146 -- supported for shared libraries.
|
|
|
147
|
|
|
148 end Module_Name;
|
|
|
149
|
|
|
150 package body Module_Name is separate;
|
|
|
151
|
|
|
152 function Executable_Name return String;
|
|
|
153 -- Returns the executable name as reported by argv[0]. If gnat_argv not
|
|
131
|
154 -- initialized, return an empty string. If the argv[0] executable is not
|
|
|
155 -- found in the PATH, return it unresolved.
|
|
111
|
156
|
|
|
157 function Get_Executable_Load_Address return System.Address;
|
|
|
158 pragma Import
|
|
|
159 (C,
|
|
|
160 Get_Executable_Load_Address,
|
|
|
161 "__gnat_get_executable_load_address");
|
|
|
162 -- Get the load address of the executable, or Null_Address if not known
|
|
|
163
|
|
|
164 procedure Hexa_Traceback
|
|
|
165 (Traceback : Tracebacks_Array;
|
|
|
166 Suppress_Hex : Boolean;
|
|
|
167 Res : in out Bounded_String);
|
|
|
168 -- Non-symbolic traceback (simply write addresses in hexa)
|
|
|
169
|
|
|
170 procedure Symbolic_Traceback_No_Lock
|
|
|
171 (Traceback : Tracebacks_Array;
|
|
|
172 Suppress_Hex : Boolean;
|
|
|
173 Res : in out Bounded_String);
|
|
|
174 -- Like the public Symbolic_Traceback_No_Lock except there is no provision
|
|
|
175 -- against concurrent accesses.
|
|
|
176
|
|
|
177 procedure Module_Symbolic_Traceback
|
|
|
178 (Traceback : Tracebacks_Array;
|
|
|
179 Module : Module_Cache;
|
|
|
180 Suppress_Hex : Boolean;
|
|
|
181 Res : in out Bounded_String);
|
|
|
182 -- Returns the Traceback for a given module
|
|
|
183
|
|
|
184 procedure Multi_Module_Symbolic_Traceback
|
|
|
185 (Traceback : Tracebacks_Array;
|
|
|
186 Suppress_Hex : Boolean;
|
|
|
187 Res : in out Bounded_String);
|
|
|
188 -- Build string containing symbolic traceback for the given call chain
|
|
|
189
|
|
|
190 procedure Multi_Module_Symbolic_Traceback
|
|
|
191 (Traceback : Tracebacks_Array;
|
|
|
192 Module : Module_Cache;
|
|
|
193 Suppress_Hex : Boolean;
|
|
|
194 Res : in out Bounded_String);
|
|
|
195 -- Likewise but using Module
|
|
|
196
|
|
|
197 Max_String_Length : constant := 4096;
|
|
|
198 -- Arbitrary limit on Bounded_Str length
|
|
|
199
|
|
|
200 -----------
|
|
|
201 -- Value --
|
|
|
202 -----------
|
|
|
203
|
|
|
204 function Value (Item : System.Address) return String is
|
|
|
205 begin
|
|
|
206 if Item /= Null_Address then
|
|
|
207 for J in Big_String'Range loop
|
|
|
208 if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then
|
|
|
209 return Big_String_Conv.To_Pointer (Item) (1 .. J - 1);
|
|
|
210 end if;
|
|
|
211 end loop;
|
|
|
212 end if;
|
|
|
213
|
|
|
214 return "";
|
|
|
215 end Value;
|
|
|
216
|
|
|
217 -------------------------
|
|
|
218 -- Add_Module_To_Cache --
|
|
|
219 -------------------------
|
|
|
220
|
|
131
|
221 procedure Add_Module_To_Cache (Module_Name : String;
|
|
|
222 Load_Address : System.Address)
|
|
|
223 is
|
|
111
|
224 Module : Module_Cache_Acc;
|
|
|
225 Success : Boolean;
|
|
|
226 begin
|
|
|
227 Module := new Module_Cache;
|
|
131
|
228 Init_Module (Module.all, Success, Module_Name, Load_Address);
|
|
111
|
229 if not Success then
|
|
|
230 Free (Module);
|
|
|
231 return;
|
|
|
232 end if;
|
|
|
233 Module.Chain := Cache_Chain;
|
|
|
234 Cache_Chain := Module;
|
|
|
235 end Add_Module_To_Cache;
|
|
|
236
|
|
|
237 ----------------------
|
|
|
238 -- Init_Exec_Module --
|
|
|
239 ----------------------
|
|
|
240
|
|
|
241 procedure Init_Exec_Module is
|
|
|
242 begin
|
|
|
243 if Exec_Module_State = Uninitialized then
|
|
|
244 declare
|
|
|
245 Exec_Path : constant String := Executable_Name;
|
|
|
246 Exec_Load : constant Address := Get_Executable_Load_Address;
|
|
|
247 Success : Boolean;
|
|
|
248 begin
|
|
|
249 Init_Module (Exec_Module, Success, Exec_Path, Exec_Load);
|
|
|
250
|
|
|
251 if Success then
|
|
|
252 Exec_Module_State := Initialized;
|
|
|
253 else
|
|
|
254 Exec_Module_State := Failed;
|
|
|
255 end if;
|
|
|
256 end;
|
|
|
257 end if;
|
|
|
258 end Init_Exec_Module;
|
|
|
259
|
|
|
260 --------
|
|
|
261 -- Lt --
|
|
|
262 --------
|
|
|
263
|
|
|
264 function Lt (Left, Right : Module_Cache_Acc) return Boolean is
|
|
|
265 begin
|
|
131
|
266 return Low_Address (Left.C) < Low_Address (Right.C);
|
|
111
|
267 end Lt;
|
|
|
268
|
|
|
269 -----------------------------
|
|
|
270 -- Module_Cache_Array_Sort --
|
|
|
271 -----------------------------
|
|
|
272
|
|
|
273 procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort
|
|
|
274 (Natural,
|
|
|
275 Module_Cache_Acc,
|
|
|
276 Module_Array,
|
|
|
277 Lt);
|
|
|
278
|
|
|
279 ------------------
|
|
|
280 -- Enable_Cache --
|
|
|
281 ------------------
|
|
|
282
|
|
|
283 procedure Enable_Cache (Include_Modules : Boolean := False) is
|
|
|
284 begin
|
|
|
285 -- Can be called at most once
|
|
|
286 if Cache_Chain /= null then
|
|
|
287 return;
|
|
|
288 end if;
|
|
|
289
|
|
|
290 -- Add all modules
|
|
|
291 Init_Exec_Module;
|
|
131
|
292
|
|
|
293 if Exec_Module_State = Failed then
|
|
|
294 raise Program_Error with
|
|
|
295 "cannot enable cache, executable state initialization failed.";
|
|
|
296 end if;
|
|
|
297
|
|
111
|
298 Cache_Chain := Exec_Module'Access;
|
|
|
299
|
|
|
300 if Include_Modules then
|
|
|
301 Module_Name.Build_Cache_For_All_Modules;
|
|
|
302 end if;
|
|
|
303
|
|
|
304 -- Build and fill the array of modules
|
|
|
305 declare
|
|
|
306 Count : Natural;
|
|
|
307 Module : Module_Cache_Acc;
|
|
|
308 begin
|
|
|
309 for Phase in 1 .. 2 loop
|
|
|
310 Count := 0;
|
|
|
311 Module := Cache_Chain;
|
|
|
312 while Module /= null loop
|
|
|
313 Count := Count + 1;
|
|
|
314
|
|
|
315 if Phase = 1 then
|
|
|
316 Enable_Cache (Module.C);
|
|
|
317 else
|
|
|
318 Modules_Cache (Count) := Module;
|
|
|
319 end if;
|
|
|
320 Module := Module.Chain;
|
|
|
321 end loop;
|
|
|
322
|
|
|
323 if Phase = 1 then
|
|
|
324 Modules_Cache := new Module_Array (1 .. Count);
|
|
|
325 end if;
|
|
|
326 end loop;
|
|
|
327 end;
|
|
|
328
|
|
|
329 -- Sort the array
|
|
|
330 Module_Cache_Array_Sort (Modules_Cache.all);
|
|
|
331 end Enable_Cache;
|
|
|
332
|
|
|
333 ---------------------
|
|
|
334 -- Executable_Name --
|
|
|
335 ---------------------
|
|
|
336
|
|
|
337 function Executable_Name return String is
|
|
|
338 -- We have to import gnat_argv as an Address to match the type of
|
|
|
339 -- gnat_argv in the binder generated file. Otherwise, we get spurious
|
|
|
340 -- warnings about type mismatch when LTO is turned on.
|
|
|
341
|
|
|
342 Gnat_Argv : System.Address;
|
|
|
343 pragma Import (C, Gnat_Argv, "gnat_argv");
|
|
|
344
|
|
|
345 type Argv_Array is array (0 .. 0) of System.Address;
|
|
|
346 package Conv is new System.Address_To_Access_Conversions (Argv_Array);
|
|
|
347
|
|
|
348 function locate_exec_on_path (A : System.Address) return System.Address;
|
|
|
349 pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path");
|
|
|
350
|
|
|
351 begin
|
|
|
352 if Gnat_Argv = Null_Address then
|
|
|
353 return "";
|
|
|
354 end if;
|
|
|
355
|
|
131
|
356 -- See if we can resolve argv[0] to a full path (to a file that we will
|
|
|
357 -- be able to open). If the resolution fails, we were probably spawned
|
|
|
358 -- by an imprecise exec call, typically passing a mere file name as
|
|
|
359 -- argv[0] for a program in the current directory with '.' not on PATH.
|
|
|
360 -- Best we can do is fallback to argv[0] unchanged in this case. If we
|
|
|
361 -- fail opening that downstream, we'll just bail out.
|
|
|
362
|
|
111
|
363 declare
|
|
131
|
364 Argv0 : constant System.Address
|
|
|
365 := Conv.To_Pointer (Gnat_Argv) (0);
|
|
|
366
|
|
|
367 Resolved_Argv0 : constant System.Address
|
|
|
368 := locate_exec_on_path (Argv0);
|
|
|
369
|
|
|
370 Exe_Argv : constant System.Address
|
|
|
371 := (if Resolved_Argv0 /= System.Null_Address
|
|
|
372 then Resolved_Argv0
|
|
|
373 else Argv0);
|
|
|
374
|
|
|
375 Result : constant String := Value (Exe_Argv);
|
|
111
|
376
|
|
|
377 begin
|
|
|
378 -- The buffer returned by locate_exec_on_path was allocated using
|
|
131
|
379 -- malloc and we should release this memory.
|
|
111
|
380
|
|
131
|
381 if Resolved_Argv0 /= Null_Address then
|
|
|
382 System.CRTL.free (Resolved_Argv0);
|
|
111
|
383 end if;
|
|
|
384
|
|
|
385 return Result;
|
|
|
386 end;
|
|
|
387 end Executable_Name;
|
|
|
388
|
|
|
389 ------------------
|
|
|
390 -- Close_Module --
|
|
|
391 ------------------
|
|
|
392
|
|
|
393 procedure Close_Module (Module : in out Module_Cache) is
|
|
|
394 begin
|
|
|
395 Close (Module.C);
|
|
|
396 Strings.Free (Module.Name);
|
|
|
397 end Close_Module;
|
|
|
398
|
|
|
399 -----------------
|
|
|
400 -- Init_Module --
|
|
|
401 -----------------
|
|
|
402
|
|
|
403 procedure Init_Module
|
|
|
404 (Module : out Module_Cache;
|
|
|
405 Success : out Boolean;
|
|
|
406 Module_Name : String;
|
|
|
407 Load_Address : Address := Null_Address)
|
|
|
408 is
|
|
|
409 begin
|
|
|
410 -- Early return if the module is not known
|
|
|
411
|
|
|
412 if Module_Name = "" then
|
|
|
413 Success := False;
|
|
|
414 return;
|
|
|
415 end if;
|
|
|
416
|
|
|
417 Open (Module_Name, Module.C, Success);
|
|
|
418
|
|
|
419 -- If a module can't be opened just return now, we just cannot give more
|
|
|
420 -- information in this case.
|
|
|
421
|
|
|
422 if not Success then
|
|
|
423 return;
|
|
|
424 end if;
|
|
|
425
|
|
|
426 Set_Load_Address (Module.C, Load_Address);
|
|
|
427
|
|
|
428 Module.Name := new String'(Module_Name);
|
|
|
429 end Init_Module;
|
|
|
430
|
|
|
431 -------------------------------
|
|
|
432 -- Module_Symbolic_Traceback --
|
|
|
433 -------------------------------
|
|
|
434
|
|
|
435 procedure Module_Symbolic_Traceback
|
|
|
436 (Traceback : Tracebacks_Array;
|
|
|
437 Module : Module_Cache;
|
|
|
438 Suppress_Hex : Boolean;
|
|
|
439 Res : in out Bounded_String)
|
|
|
440 is
|
|
|
441 Success : Boolean := False;
|
|
|
442 begin
|
|
|
443 if Symbolic.Module_Name.Is_Supported then
|
|
|
444 Append (Res, '[');
|
|
|
445 Append (Res, Module.Name.all);
|
|
|
446 Append (Res, ']' & ASCII.LF);
|
|
|
447 end if;
|
|
|
448
|
|
|
449 Dwarf_Lines.Symbolic_Traceback
|
|
|
450 (Module.C,
|
|
|
451 Traceback,
|
|
|
452 Suppress_Hex,
|
|
|
453 Success,
|
|
|
454 Res);
|
|
|
455
|
|
|
456 if not Success then
|
|
|
457 Hexa_Traceback (Traceback, Suppress_Hex, Res);
|
|
|
458 end if;
|
|
|
459
|
|
|
460 -- We must not allow an unhandled exception here, since this function
|
|
|
461 -- may be installed as a decorator for all automatic exceptions.
|
|
|
462
|
|
|
463 exception
|
|
|
464 when others =>
|
|
|
465 return;
|
|
|
466 end Module_Symbolic_Traceback;
|
|
|
467
|
|
|
468 -------------------------------------
|
|
|
469 -- Multi_Module_Symbolic_Traceback --
|
|
|
470 -------------------------------------
|
|
|
471
|
|
|
472 procedure Multi_Module_Symbolic_Traceback
|
|
|
473 (Traceback : Tracebacks_Array;
|
|
|
474 Suppress_Hex : Boolean;
|
|
|
475 Res : in out Bounded_String)
|
|
|
476 is
|
|
|
477 F : constant Natural := Traceback'First;
|
|
|
478 begin
|
|
|
479 if Traceback'Length = 0 or else Is_Full (Res) then
|
|
|
480 return;
|
|
|
481 end if;
|
|
|
482
|
|
|
483 if Modules_Cache /= null then
|
|
|
484 -- Search in the cache
|
|
|
485
|
|
|
486 declare
|
|
|
487 Addr : constant Address := Traceback (F);
|
|
|
488 Hi, Lo, Mid : Natural;
|
|
|
489 begin
|
|
|
490 Lo := Modules_Cache'First;
|
|
|
491 Hi := Modules_Cache'Last;
|
|
|
492 while Lo <= Hi loop
|
|
|
493 Mid := (Lo + Hi) / 2;
|
|
131
|
494 if Addr < Low_Address (Modules_Cache (Mid).C) then
|
|
111
|
495 Hi := Mid - 1;
|
|
|
496 elsif Is_Inside (Modules_Cache (Mid).C, Addr) then
|
|
|
497 Multi_Module_Symbolic_Traceback
|
|
|
498 (Traceback,
|
|
|
499 Modules_Cache (Mid).all,
|
|
|
500 Suppress_Hex,
|
|
|
501 Res);
|
|
|
502 return;
|
|
|
503 else
|
|
|
504 Lo := Mid + 1;
|
|
|
505 end if;
|
|
|
506 end loop;
|
|
|
507
|
|
|
508 -- Not found
|
|
|
509 Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
|
|
|
510 Multi_Module_Symbolic_Traceback
|
|
|
511 (Traceback (F + 1 .. Traceback'Last),
|
|
|
512 Suppress_Hex,
|
|
|
513 Res);
|
|
|
514 end;
|
|
|
515 else
|
|
|
516
|
|
|
517 -- First try the executable
|
|
|
518 if Is_Inside (Exec_Module.C, Traceback (F)) then
|
|
|
519 Multi_Module_Symbolic_Traceback
|
|
|
520 (Traceback,
|
|
|
521 Exec_Module,
|
|
|
522 Suppress_Hex,
|
|
|
523 Res);
|
|
|
524 return;
|
|
|
525 end if;
|
|
|
526
|
|
|
527 -- Otherwise, try a shared library
|
|
|
528 declare
|
|
131
|
529 Load_Addr : aliased System.Address;
|
|
|
530 M_Name : constant String :=
|
|
|
531 Module_Name.Get (Addr => Traceback (F),
|
|
|
532 Load_Addr => Load_Addr'Access);
|
|
111
|
533 Module : Module_Cache;
|
|
|
534 Success : Boolean;
|
|
|
535 begin
|
|
131
|
536 Init_Module (Module, Success, M_Name, Load_Addr);
|
|
111
|
537 if Success then
|
|
|
538 Multi_Module_Symbolic_Traceback
|
|
|
539 (Traceback,
|
|
|
540 Module,
|
|
|
541 Suppress_Hex,
|
|
|
542 Res);
|
|
|
543 Close_Module (Module);
|
|
|
544 else
|
|
|
545 -- Module not found
|
|
|
546 Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
|
|
|
547 Multi_Module_Symbolic_Traceback
|
|
|
548 (Traceback (F + 1 .. Traceback'Last),
|
|
|
549 Suppress_Hex,
|
|
|
550 Res);
|
|
|
551 end if;
|
|
|
552 end;
|
|
|
553 end if;
|
|
|
554 end Multi_Module_Symbolic_Traceback;
|
|
|
555
|
|
|
556 procedure Multi_Module_Symbolic_Traceback
|
|
|
557 (Traceback : Tracebacks_Array;
|
|
|
558 Module : Module_Cache;
|
|
|
559 Suppress_Hex : Boolean;
|
|
|
560 Res : in out Bounded_String)
|
|
|
561 is
|
|
|
562 Pos : Positive;
|
|
|
563 begin
|
|
|
564 -- Will symbolize the first address...
|
|
|
565
|
|
|
566 Pos := Traceback'First + 1;
|
|
|
567
|
|
|
568 -- ... and all addresses in the same module
|
|
|
569
|
|
|
570 Same_Module :
|
|
|
571 loop
|
|
|
572 exit Same_Module when Pos > Traceback'Last;
|
|
|
573
|
|
|
574 -- Get address to check for corresponding module name
|
|
|
575
|
|
|
576 exit Same_Module when not Is_Inside (Module.C, Traceback (Pos));
|
|
|
577
|
|
|
578 Pos := Pos + 1;
|
|
|
579 end loop Same_Module;
|
|
|
580
|
|
|
581 Module_Symbolic_Traceback
|
|
|
582 (Traceback (Traceback'First .. Pos - 1),
|
|
|
583 Module,
|
|
|
584 Suppress_Hex,
|
|
|
585 Res);
|
|
|
586 Multi_Module_Symbolic_Traceback
|
|
|
587 (Traceback (Pos .. Traceback'Last),
|
|
|
588 Suppress_Hex,
|
|
|
589 Res);
|
|
|
590 end Multi_Module_Symbolic_Traceback;
|
|
|
591
|
|
|
592 --------------------
|
|
|
593 -- Hexa_Traceback --
|
|
|
594 --------------------
|
|
|
595
|
|
|
596 procedure Hexa_Traceback
|
|
|
597 (Traceback : Tracebacks_Array;
|
|
|
598 Suppress_Hex : Boolean;
|
|
|
599 Res : in out Bounded_String)
|
|
|
600 is
|
|
|
601 use System.Traceback_Entries;
|
|
|
602 begin
|
|
|
603 if Suppress_Hex then
|
|
|
604 Append (Res, "...");
|
|
|
605 Append (Res, ASCII.LF);
|
|
|
606 else
|
|
|
607 for J in Traceback'Range loop
|
|
|
608 Append_Address (Res, PC_For (Traceback (J)));
|
|
|
609 Append (Res, ASCII.LF);
|
|
|
610 end loop;
|
|
|
611 end if;
|
|
|
612 end Hexa_Traceback;
|
|
|
613
|
|
|
614 --------------------------------
|
|
|
615 -- Symbolic_Traceback_No_Lock --
|
|
|
616 --------------------------------
|
|
|
617
|
|
|
618 procedure Symbolic_Traceback_No_Lock
|
|
|
619 (Traceback : Tracebacks_Array;
|
|
|
620 Suppress_Hex : Boolean;
|
|
|
621 Res : in out Bounded_String)
|
|
|
622 is
|
|
|
623 begin
|
|
|
624 if Symbolic.Module_Name.Is_Supported then
|
|
|
625 Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res);
|
|
|
626 else
|
|
|
627 if Exec_Module_State = Failed then
|
|
|
628 Append (Res, "Call stack traceback locations:" & ASCII.LF);
|
|
|
629 Hexa_Traceback (Traceback, Suppress_Hex, Res);
|
|
|
630 else
|
|
|
631 Module_Symbolic_Traceback
|
|
|
632 (Traceback,
|
|
|
633 Exec_Module,
|
|
|
634 Suppress_Hex,
|
|
|
635 Res);
|
|
|
636 end if;
|
|
|
637 end if;
|
|
|
638 end Symbolic_Traceback_No_Lock;
|
|
|
639
|
|
|
640 ------------------------
|
|
|
641 -- Symbolic_Traceback --
|
|
|
642 ------------------------
|
|
|
643
|
|
|
644 function Symbolic_Traceback
|
|
|
645 (Traceback : Tracebacks_Array;
|
|
|
646 Suppress_Hex : Boolean) return String
|
|
|
647 is
|
|
|
648 Res : Bounded_String (Max_Length => Max_String_Length);
|
|
|
649 begin
|
|
|
650 System.Soft_Links.Lock_Task.all;
|
|
|
651 Init_Exec_Module;
|
|
|
652 Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res);
|
|
|
653 System.Soft_Links.Unlock_Task.all;
|
|
|
654
|
|
|
655 return To_String (Res);
|
|
|
656
|
|
|
657 exception
|
|
|
658 when others =>
|
|
|
659 System.Soft_Links.Unlock_Task.all;
|
|
|
660 raise;
|
|
|
661 end Symbolic_Traceback;
|
|
|
662
|
|
|
663 function Symbolic_Traceback
|
|
|
664 (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
|
|
|
665 begin
|
|
|
666 return Symbolic_Traceback (Traceback, Suppress_Hex => False);
|
|
|
667 end Symbolic_Traceback;
|
|
|
668
|
|
|
669 function Symbolic_Traceback_No_Hex
|
|
|
670 (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
|
|
|
671 begin
|
|
|
672 return Symbolic_Traceback (Traceback, Suppress_Hex => True);
|
|
|
673 end Symbolic_Traceback_No_Hex;
|
|
|
674
|
|
|
675 function Symbolic_Traceback
|
|
|
676 (E : Ada.Exceptions.Exception_Occurrence;
|
|
|
677 Suppress_Hex : Boolean) return String
|
|
|
678 is
|
|
|
679 begin
|
|
|
680 return Symbolic_Traceback
|
|
|
681 (Ada.Exceptions.Traceback.Tracebacks (E),
|
|
|
682 Suppress_Hex);
|
|
|
683 end Symbolic_Traceback;
|
|
|
684
|
|
|
685 function Symbolic_Traceback
|
|
|
686 (E : Ada.Exceptions.Exception_Occurrence) return String
|
|
|
687 is
|
|
|
688 begin
|
|
|
689 return Symbolic_Traceback (E, Suppress_Hex => False);
|
|
|
690 end Symbolic_Traceback;
|
|
|
691
|
|
|
692 function Symbolic_Traceback_No_Hex
|
|
|
693 (E : Ada.Exceptions.Exception_Occurrence) return String is
|
|
|
694 begin
|
|
|
695 return Symbolic_Traceback (E, Suppress_Hex => True);
|
|
|
696 end Symbolic_Traceback_No_Hex;
|
|
|
697
|
|
|
698 Exception_Tracebacks_Symbolic : Integer;
|
|
|
699 pragma Import
|
|
|
700 (C,
|
|
|
701 Exception_Tracebacks_Symbolic,
|
|
|
702 "__gl_exception_tracebacks_symbolic");
|
|
|
703 -- Boolean indicating whether symbolic tracebacks should be generated.
|
|
|
704
|
|
|
705 use Standard_Library;
|
|
|
706 begin
|
|
|
707 -- If this version of this package is available, and the binder switch -Es
|
|
|
708 -- was given, then we want to use this as the decorator by default, and we
|
|
|
709 -- want to turn on tracing for Unhandled_Raise_In_Main. Note that the user
|
|
|
710 -- cannot have already set Exception_Trace, because the runtime library is
|
|
|
711 -- elaborated before user-defined code.
|
|
|
712
|
|
|
713 if Exception_Tracebacks_Symbolic /= 0 then
|
|
|
714 Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access);
|
|
|
715 pragma Assert (Exception_Trace = RM_Convention);
|
|
|
716 Exception_Trace := Unhandled_Raise_In_Main;
|
|
|
717 end if;
|
|
|
718 end System.Traceback.Symbolic;
|
