gcc/ada/libgnat/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-2024, 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 -- 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 --  This is the GNU/Linux specific version of this package
  33
  34 with Interfaces.C; use Interfaces.C;
  35
  36 separate (System.Traceback.Symbolic)
  37
  38 package body Module_Name is
  39
  40    pragma Linker_Options ("-ldl");
  41
  42    function Is_Shared_Lib (Base : Address) return Boolean;
  43    --  Returns True if a shared library
  44
  45    -------------------
  46    -- Is_Shared_Lib --
  47    -------------------
  48
  49    function Is_Shared_Lib (Base : Address) return Boolean is
  50       EI_NIDENT : constant := 16;
  51       type u16 is mod 2 ** 16;
  52
  53       --  Just declare the needed header information, we just need to read the
  54       --  type encoded in the second field.
  55
  56       type Elf32_Ehdr is record
  57          e_ident : char_array (1 .. EI_NIDENT);
  58          e_type  : u16;
  59       end record;
  60
  61       ET_DYN : constant := 3; -- A shared lib if e_type = ET_DYN
  62
  63       Header : Elf32_Ehdr;
  64       pragma Import (Ada, Header);
  65       --  Suppress initialization in Normalized_Scalars mode
  66       for Header'Address use Base;
  67
  68    begin
  69       return Header.e_type = ET_DYN;
  70    exception
  71       when others =>
  72          return False;
  73    end Is_Shared_Lib;
  74
  75    ---------------------------------
  76    -- Build_Cache_For_All_Modules --
  77    ---------------------------------
  78
  79    procedure Build_Cache_For_All_Modules is
  80       type link_map;
  81       type link_map_acc is access all link_map;
  82       pragma Convention (C, link_map_acc);
  83
  84       type link_map is record
  85          l_addr : aliased Address;
  86          --  Base address of the shared object
  87
  88          l_name : aliased Address;
  89          --  Null-terminated absolute file name
  90
  91          l_ld   : aliased Address;
  92          --  Dynamic section
  93
  94          l_next, l_prev : aliased link_map_acc;
  95          --  Chain
  96       end record;
  97       pragma Convention (C, link_map);
  98
  99       type r_debug_state is (RT_CONSISTENT, RT_ADD, RT_DELETE);
 100       pragma Convention (C, r_debug_state);
 101       pragma Unreferenced (RT_CONSISTENT, RT_ADD, RT_DELETE);
 102
 103       type r_debug_type is record
 104          r_version : aliased int;
 105          r_map     : aliased link_map_acc;
 106          r_brk     : aliased Address;
 107          r_state   : aliased r_debug_state;
 108          r_ldbase  : aliased Address;
 109       end record;
 110       pragma Convention (C, r_debug_type);
 111
 112       r_debug : r_debug_type;
 113       pragma Import (C, r_debug, "_r_debug");
 114
 115       lm : link_map_acc;
 116    begin
 117       lm := r_debug.r_map;
 118       while lm /= null loop
 119          if Big_String_Conv.To_Pointer (lm.l_name) (1) /= ASCII.NUL then
 120             --  Discard non-file (like the executable itself or the gate).
 121             Add_Module_To_Cache (Value (lm.l_name), lm.l_addr);
 122          end if;
 123          lm := lm.l_next;
 124       end loop;
 125    end Build_Cache_For_All_Modules;
 126
 127    ---------
 128    -- Get --
 129    ---------
 130
 131    --  The principle is:
 132
 133    --  1. We get information about the module containing the address.
 134
 135    --  2. We check whether the module is a shared library.
 136
 137    --  3. For shared libraries, we return the non-relocated address (so
 138    --     the absolute address in the shared library).
 139
 140    --  4. We also return the full pathname of the module containing this
 141    --     address.
 142
 143    function Get
 144      (Addr      : System.Address;
 145       Load_Addr : access System.Address) return String
 146    is
 147       --  Dl_info record for Linux, used to get sym reloc offset
 148
 149       type Dl_info is record
 150          dli_fname : System.Address;
 151          dli_fbase : System.Address;
 152          dli_sname : System.Address;
 153          dli_saddr : System.Address;
 154       end record;
 155
 156       function dladdr
 157         (addr : System.Address;
 158          info : not null access Dl_info) return int;
 159       pragma Import (C, dladdr, "dladdr");
 160       --  This is a Linux extension and not POSIX
 161
 162       info : aliased Dl_info;
 163
 164    begin
 165       Load_Addr.all := System.Null_Address;
 166
 167       if dladdr (Addr, info'Access) /= 0 then
 168
 169          --  If we have a shared library we need to adjust the address to
 170          --  be relative to the base address of the library.
 171
 172          if Is_Shared_Lib (info.dli_fbase) then
 173             Load_Addr.all := info.dli_fbase;
 174          end if;
 175
 176          return Value (info.dli_fname);
 177
 178       --  Not found, fallback to executable name
 179
 180       else
 181          return "";
 182       end if;
 183
 184    exception
 185       when others =>
 186          return "";
 187    end Get;
 188
 189    ------------------
 190    -- Is_Supported --
 191    ------------------
 192
 193    function Is_Supported return Boolean is
 194    begin
 195       return True;
 196    end Is_Supported;
 197
 198 end Module_Name;