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