s-dwalin.ads, [...]: New.

2017-09-08  Arnaud Charlet <charlet@adacore.com>

	* s-dwalin.ads, s-dwalin.adb, s-trasym-dwarf.adb, s-objrea.ads,
	s-objrea.adb, s-tsmona-linux.adb, s-tsmona-mingw.adb: New.
	* gcc-interface/Makefile.in: Enable s-trasym-dwarf.adb on x86*linux.

From-SVN: r251887

gcc/ada/gcc-interface/Makefile.in

@@ -429,6 +429,25 @@ X86_64_TARGET_PAIRS = \
   a-numaux.adb<a-numaux-x86.adb \
   s-atocou.adb<s-atocou-builtin.adb
 
+# Implementation of symbolic traceback based on dwarf
+TRASYM_DWARF_UNIX_PAIRS = \
+  s-trasym.adb<s-trasym-dwarf.adb \
+  s-mmosin.ads<s-mmosin-unix.ads \
+  s-mmosin.adb<s-mmosin-unix.adb \
+  s-mmauni.ads<s-mmauni-long.ads
+
+TRASYM_DWARF_MINGW_PAIRS = \
+  s-trasym.adb<s-trasym-dwarf.adb \
+  s-mmosin.ads<s-mmosin-mingw.ads \
+  s-mmosin.adb<s-mmosin-mingw.adb
+
+TRASYM_DWARF_COMMON_OBJS = s-objrea$(objext) s-dwalin$(objext) s-mmap$(objext) \
+  s-mmosin$(objext)
+
+TRASYM_DWARF_UNIX_OBJS = $(TRASYM_DWARF_COMMON_OBJS) s-mmauni$(objext)
+
+TRASYM_DWARF_MINGW_OBJS = $(TRASYM_DWARF_COMMON_OBJS)
+
 # Shared library version
 LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)ada/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/'))
 
@@ -1085,7 +1104,9 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),)
   s-inmaop.adb<s-inmaop-posix.adb \
   s-intman.adb<s-intman-posix.adb \
   s-tpopsp.adb<s-tpopsp-tls.adb \
+  $(TRASYM_DWARF_UNIX_PAIRS) \
   g-sercom.adb<g-sercom-linux.adb \
+  s-tsmona.adb<s-tsmona-linux.adb \
   a-exetim.adb<a-exetim-posix.adb \
   a-exetim.ads<a-exetim-default.ads \
   s-linux.ads<s-linux.ads \
@@ -1111,6 +1132,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),)
   EH_MECHANISM=-gcc
   THREADSLIB = -lpthread -lrt
   EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
+  EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS)
   EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
 
   TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
@@ -1907,6 +1929,8 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),)
   s-tpopsp.adb<s-tpopsp-tls.adb \
   s-taspri.ads<s-taspri-posix.ads \
   g-sercom.adb<g-sercom-linux.adb \
+  $(TRASYM_DWARF_UNIX_PAIRS) \
+  s-tsmona.adb<s-tsmona-linux.adb \
   $(ATOMICS_TARGET_PAIRS) \
   $(X86_64_TARGET_PAIRS) \
   system.ads<system-linux-x86.ads
@@ -1914,6 +1938,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),)
   TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
 
   EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
+  EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS)
   EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
 
   EH_MECHANISM=-gcc

gcc/ada/s-dwalin.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                   S Y S T E M . D W A R F _ L I N E S                    --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--           Copyright (C) 2009-2017, Free Software Foundation, Inc.        --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package provides routines to read DWARF line number information from
+--  a generic object file with as little overhead as possible. This allows
+--  conversions from PC addresses to human readable source locations.
+--
+--  Objects must be built with debugging information, however only the
+--  .debug_line section of the object file is referenced. In cases where object
+--  size is a consideration it's possible to strip all other .debug sections,
+--  which will decrease the size of the object significantly.
+
+pragma Polling (Off);
+--  We must turn polling off for this unit, because otherwise we can get
+--  elaboration circularities when polling is turned on
+
+with Ada.Exceptions.Traceback;
+
+with System.Object_Reader;
+with System.Storage_Elements;
+with System.Bounded_Strings;
+
+package System.Dwarf_Lines is
+
+   package AET renames Ada.Exceptions.Traceback;
+   package SOR renames System.Object_Reader;
+
+   type Dwarf_Context (In_Exception : Boolean := False) is private;
+   --  Type encapsulation the state of the Dwarf reader. When In_Exception
+   --  is True we are parsing as part of a exception handler decorator, we do
+   --  not want an exception to be raised, the parsing is done safely skipping
+   --  DWARF file that cannot be read or with stripped debug section for
+   --  example.
+
+   procedure Open
+     (File_Name :     String;
+      C         : out Dwarf_Context;
+      Success   : out Boolean);
+   procedure Close (C : in out Dwarf_Context);
+   --  Open and close files
+
+   procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address);
+   --  Set the load address of a file. This is used to rebase PIE (Position
+   --  Independant Executable) binaries.
+
+   function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean;
+   pragma Inline (Is_Inside);
+   --  Return true iff Addr is within the module
+
+   function Low (C : Dwarf_Context) return Address;
+   pragma Inline (Low);
+   --  Return the lowest address of C
+
+   procedure Dump (C : in out Dwarf_Context);
+   --  Dump each row found in the object's .debug_lines section to standard out
+
+   procedure Dump_Cache (C : Dwarf_Context);
+   --  Dump the cache (if present)
+
+   procedure Enable_Cache (C : in out Dwarf_Context);
+   --  Read symbols information to speed up Symbolic_Traceback.
+
+   procedure Symbolic_Traceback
+     (Cin          :        Dwarf_Context;
+      Traceback    :        AET.Tracebacks_Array;
+      Suppress_Hex :        Boolean;
+      Symbol_Found : in out Boolean;
+      Res          : in out System.Bounded_Strings.Bounded_String);
+   --  Generate a string for a traceback suitable for displaying to the user.
+   --  If one or more symbols are found, Symbol_Found is set to True. This
+   --  allows the caller to fall back to hexadecimal addresses.
+
+   Dwarf_Error : exception;
+   --  Raised if a problem is encountered parsing DWARF information. Can be a
+   --  result of a logic error or malformed DWARF information.
+
+private
+   --  The following section numbers reference
+
+   --    "DWARF Debugging Information Format, Version 3"
+
+   --  published by the Standards Group, http://freestandards.org.
+
+   --  6.2.2 State Machine Registers
+
+   type Line_Info_Registers is record
+      Address        : SOR.uint64;
+      File           : SOR.uint32;
+      Line           : SOR.uint32;
+      Column         : SOR.uint32;
+      Is_Stmt        : Boolean;
+      Basic_Block    : Boolean;
+      End_Sequence   : Boolean;
+      Prologue_End   : Boolean;
+      Epilogue_Begin : Boolean;
+      ISA            : SOR.uint32;
+      Is_Row         : Boolean;
+   end record;
+
+   --  6.2.4 The Line Number Program Prologue
+
+   MAX_OPCODE_LENGTHS : constant := 256;
+
+   type Opcodes_Lengths_Array is
+     array (SOR.uint32 range 1 .. MAX_OPCODE_LENGTHS) of SOR.uint8;
+
+   type Line_Info_Prologue is record
+      Unit_Length       : SOR.uint32;
+      Version           : SOR.uint16;
+      Prologue_Length   : SOR.uint32;
+      Min_Isn_Length    : SOR.uint8;
+      Default_Is_Stmt   : SOR.uint8;
+      Line_Base         : SOR.int8;
+      Line_Range        : SOR.uint8;
+      Opcode_Base       : SOR.uint8;
+      Opcode_Lengths    : Opcodes_Lengths_Array;
+      Includes_Offset   : SOR.Offset;
+      File_Names_Offset : SOR.Offset;
+   end record;
+
+   type Search_Entry is record
+      First : SOR.uint32;
+      Size  : SOR.uint32;
+      --  Function bounds as offset to the base address.
+
+      Sym : SOR.uint32;
+      --  Symbol offset to get the name.
+
+      Line : SOR.uint32;
+      --  Dwarf line offset.
+   end record;
+
+   type Search_Array is array (Natural range <>) of Search_Entry;
+
+   type Search_Array_Access is access Search_Array;
+
+   type Dwarf_Context (In_Exception : Boolean := False) is record
+      Load_Slide : System.Storage_Elements.Integer_Address := 0;
+      Low, High  : Address;
+      --  Bounds of the module
+
+      Obj : SOR.Object_File_Access;
+      --  The object file containing dwarf sections
+
+      Has_Debug : Boolean;
+      --  True if all debug sections are available
+
+      Cache : Search_Array_Access;
+      --  Quick access to symbol and debug info (when present).
+
+      Lines   : SOR.Mapped_Stream;
+      Aranges : SOR.Mapped_Stream;
+      Info    : SOR.Mapped_Stream;
+      Abbrev  : SOR.Mapped_Stream;
+      --  Dwarf line, aranges, info and abbrev sections
+
+      Prologue      : Line_Info_Prologue;
+      Registers     : Line_Info_Registers;
+      Next_Prologue : SOR.Offset;
+      --  State for lines
+   end record;
+
+end System.Dwarf_Lines;

gcc/ada/s-tsmona-linux.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--  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   --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                     Copyright (C) 2012-2017, AdaCore                     --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the GNU/Linux specific version of this package
+with Interfaces.C;              use Interfaces.C;
+
+with System.Address_Operations; use System.Address_Operations;
+
+separate (System.Traceback.Symbolic)
+
+package body Module_Name is
+
+   use System;
+
+   pragma Linker_Options ("-ldl");
+
+   function Is_Shared_Lib (Base : Address) return Boolean;
+   --  Returns True if a shared library
+
+   --  The principle is:
+
+   --  1. We get information about the module containing the address.
+
+   --  2. We check that the full pathname is pointing to a shared library.
+
+   --  3. for shared libraries, we return the non relocated address (so
+   --     the absolute address in the shared library).
+
+   --  4. we also return the full pathname of the module containing this
+   --     address.
+
+   -------------------
+   -- Is_Shared_Lib --
+   -------------------
+
+   function Is_Shared_Lib (Base : Address) return Boolean is
+      EI_NIDENT : constant := 16;
+      type u16 is mod 2 ** 16;
+
+      --  Just declare the needed header information, we just need to read the
+      --  type encoded in the second field.
+
+      type Elf32_Ehdr is record
+         e_ident : char_array (1 .. EI_NIDENT);
+         e_type  : u16;
+      end record;
+
+      ET_DYN : constant := 3; -- A shared lib if e_type = ET_DYN
+
+      Header : Elf32_Ehdr;
+      pragma Import (Ada, Header);
+      --  Suppress initialization in Normalized_Scalars mode
+      for Header'Address use Base;
+
+   begin
+      return Header.e_type = ET_DYN;
+   exception
+      when others =>
+         return False;
+   end Is_Shared_Lib;
+
+   ---------------------------------
+   -- Build_Cache_For_All_Modules --
+   ---------------------------------
+
+   procedure Build_Cache_For_All_Modules is
+      type link_map;
+      type link_map_acc is access all link_map;
+      pragma Convention (C, link_map_acc);
+
+      type link_map is record
+         l_addr : Address;
+         --  Base address of the shared object
+
+         l_name : Address;
+         --  Null-terminated absolute file name
+
+         l_ld   : Address;
+         --  Dynamic section
+
+         l_next, l_prev : link_map_acc;
+         --  Chain
+      end record;
+      pragma Convention (C, link_map);
+
+      type r_debug_type is record
+         r_version : Integer;
+         r_map : link_map_acc;
+      end record;
+      pragma Convention (C, r_debug_type);
+
+      r_debug : r_debug_type;
+      pragma Import (C, r_debug, "_r_debug");
+
+      lm : link_map_acc;
+   begin
+      lm := r_debug.r_map;
+      while lm /= null loop
+         if Big_String_Conv.To_Pointer (lm.l_name) (1) /= ASCII.NUL then
+            --  Discard non-file (like the executable itself or the gate).
+            Add_Module_To_Cache (Value (lm.l_name));
+         end if;
+         lm := lm.l_next;
+      end loop;
+   end Build_Cache_For_All_Modules;
+
+   ---------
+   -- Get --
+   ---------
+
+   function Get (Addr : access System.Address) return String is
+
+      --  Dl_info record for Linux, used to get sym reloc offset
+
+      type Dl_info is record
+         dli_fname : System.Address;
+         dli_fbase : System.Address;
+         dli_sname : System.Address;
+         dli_saddr : System.Address;
+      end record;
+
+      function dladdr
+        (addr : System.Address;
+         info : not null access Dl_info) return int;
+      pragma Import (C, dladdr, "dladdr");
+      --  This is a Linux extension and not POSIX
+
+      info : aliased Dl_info;
+
+   begin
+      if dladdr (Addr.all, info'Access) /= 0 then
+
+         --  If we have a shared library we need to adjust the address to
+         --  be relative to the base address of the library.
+
+         if Is_Shared_Lib (info.dli_fbase) then
+            Addr.all := SubA (Addr.all, info.dli_fbase);
+         end if;
+
+         return Value (info.dli_fname);
+
+      --  Not found, fallback to executable name
+
+      else
+         return "";
+      end if;
+
+   exception
+      when others =>
+         return "";
+   end Get;
+
+   ------------------
+   -- Is_Supported --
+   ------------------
+
+   function Is_Supported return Boolean is
+   begin
+      return True;
+   end Is_Supported;
+
+end Module_Name;

gcc/ada/s-tsmona-mingw.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--  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   --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                     Copyright (C) 2012-2017, AdaCore                     --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the Windows specific version of this package
+
+with System.Win32; use System.Win32;
+
+separate (System.Traceback.Symbolic)
+
+package body Module_Name is
+
+   use System;
+
+   ---------------------------------
+   -- Build_Cache_For_All_Modules --
+   ---------------------------------
+
+   procedure Build_Cache_For_All_Modules is
+   begin
+      null;
+   end Build_Cache_For_All_Modules;
+
+   ---------
+   -- Get --
+   ---------
+
+   function Get (Addr : access System.Address) return String is
+      Res     : DWORD;
+      hModule : aliased HANDLE;
+      Path    : String (1 .. 1_024);
+
+   begin
+      if GetModuleHandleEx
+           (GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
+            Addr.all,
+            hModule'Access) = Win32.TRUE
+      then
+         Res := GetModuleFileName (hModule, Path'Address, Path'Length);
+
+         if FreeLibrary (hModule) = Win32.FALSE then
+            null;
+         end if;
+
+         if Res > 0 then
+            return Path (1 .. Positive (Res));
+         end if;
+      end if;
+
+      return "";
+
+   exception
+      when others =>
+         return "";
+   end Get;
+
+   ------------------
+   -- Is_Supported --
+   ------------------
+
+   function Is_Supported return Boolean is
+   begin
+      return True;
+   end Is_Supported;
+
+end Module_Name;