File : s-tsmona-linux.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2012-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 -- This is the GNU/Linux specific version of this package
33
34 with Interfaces.C; use Interfaces.C;
35
36 with System.Address_Operations; use System.Address_Operations;
37
38 separate (System.Traceback.Symbolic)
39
40 package body Module_Name is
41
42 use System;
43
44 pragma Linker_Options ("-ldl");
45
46 -- The principle is:
47
48 -- 1. We get information about the module containing the address.
49
50 -- 2. We check that the full pathname is pointing to a shared library.
51
52 -- 3. for shared libraries, we return the non relocated address (so
53 -- the absolute address in the shared library).
54
55 -- 4. we also return the full pathname of the module containing this
56 -- address.
57
58 ---------
59 -- Get --
60 ---------
61
62 function Get (Addr : access System.Address) return String is
63
64 -- Dl_info record for Linux, used to get sym reloc offset
65
66 type Dl_info is record
67 dli_fname : System.Address;
68 dli_fbase : System.Address;
69 dli_sname : System.Address;
70 dli_saddr : System.Address;
71 end record;
72
73 function dladdr
74 (addr : System.Address;
75 info : not null access Dl_info) return int;
76 pragma Import (C, dladdr, "dladdr");
77 -- This is a Linux extension and not POSIX
78
79 function Is_Shared_Lib (info : not null access Dl_info) return Boolean;
80 -- Returns True if a shared library
81
82 -------------------
83 -- Is_Shared_Lib --
84 -------------------
85
86 function Is_Shared_Lib (info : not null access Dl_info) return Boolean is
87 EI_NIDENT : constant := 16;
88 type u16 is mod 2 ** 16;
89
90 -- Just declare the needed header information, we just need to
91 -- read the type encoded into the second field.
92
93 type Elf32_Ehdr is record
94 e_ident : char_array (1 .. EI_NIDENT);
95 e_type : u16;
96 end record;
97
98 ET_DYN : constant := 3; -- A shared lib if e_type = ET_DYN
99
100 Header : Elf32_Ehdr;
101 pragma Import (Ada, Header);
102 -- Suppress initialization in Normalized_Scalars mode
103 for Header'Address use info.dli_fbase;
104
105 begin
106 return Header.e_type = ET_DYN;
107 exception
108 when others =>
109 return False;
110 end Is_Shared_Lib;
111
112 info : aliased Dl_info;
113
114 begin
115 if dladdr (Addr.all, info'Access) /= 0 then
116
117 -- If we have a shared library we need to adjust the address to
118 -- be relative to the base address of the library.
119
120 if Is_Shared_Lib (info'Access) then
121 Addr.all := SubA (Addr.all, info.dli_fbase);
122 end if;
123
124 return Value (info.dli_fname);
125
126 -- Not found, fallback to executable name
127
128 else
129 return "";
130 end if;
131
132 exception
133 when others =>
134 return "";
135 end Get;
136
137 ------------------
138 -- Is_Supported --
139 ------------------
140
141 function Is_Supported return Boolean is
142 begin
143 return True;
144 end Is_Supported;
145
146 end Module_Name;