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