CbC/CbC_gcc: gcc/ada/libgnat/s-trasym_

comparison gcc/ada/libgnat/s-trasym__dwarf.adb @ 111:04ced10e8804

gcc 7

author	kono
date	Fri, 27 Oct 2017 22:46:09 +0900
parents
children	84e7813d76e9

comparison

equal deleted inserted replaced

-:561a7518be6b
+:04ced10e8804
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--           S Y S T E M . T R A C E B A C K . S Y M B O L I C              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                     Copyright (C) 1999-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.      --
+--                                                                          --
+------------------------------------------------------------------------------
+--  Run-time symbolic traceback support for targets using DWARF debug data
+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.Unchecked_Deallocation;
+with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
+with Ada.Containers.Generic_Array_Sort;
+with System.Address_To_Access_Conversions;
+with System.Soft_Links;
+with System.CRTL;
+with System.Dwarf_Lines;
+with System.Exception_Traces;
+with System.Standard_Library;
+with System.Traceback_Entries;
+with System.Strings;
+with System.Bounded_Strings;
+package body System.Traceback.Symbolic is
+use System.Bounded_Strings;
+use System.Dwarf_Lines;
+subtype Big_String is String (Positive);
+--  To deal with C strings
+package Big_String_Conv is new System.Address_To_Access_Conversions
+(Big_String);
+type Module_Cache;
+type Module_Cache_Acc is access all Module_Cache;
+type Module_Cache is record
+Name : Strings.String_Access;
+--  Name of the module
+C : Dwarf_Context (In_Exception => True);
+--  Context to symbolize an address within this module
+Chain : Module_Cache_Acc;
+end record;
+procedure Free is new Ada.Unchecked_Deallocation
+(Module_Cache,
+Module_Cache_Acc);
+Cache_Chain : Module_Cache_Acc;
+--  Simply linked list of modules
+type Module_Array is array (Natural range <>) of Module_Cache_Acc;
+type Module_Array_Acc is access Module_Array;
+Modules_Cache : Module_Array_Acc;
+--  Sorted array of cached modules (if not null)
+Exec_Module : aliased Module_Cache;
+--  Context for the executable
+type Init_State is (Uninitialized, Initialized, Failed);
+Exec_Module_State : Init_State := Uninitialized;
+--  How Exec_Module is initialized
+procedure Init_Exec_Module;
+--  Initialize Exec_Module if not already initialized
+function Symbolic_Traceback
+(Traceback    : System.Traceback_Entries.Tracebacks_Array;
+Suppress_Hex : Boolean) return String;
+function Symbolic_Traceback
+(E            : Ada.Exceptions.Exception_Occurrence;
+Suppress_Hex : Boolean) return String;
+--  Suppress_Hex means do not print any hexadecimal addresses, even if the
+--  symbol is not available.
+function Lt (Left, Right : Module_Cache_Acc) return Boolean;
+--  Sort function for Module_Cache
+procedure Init_Module
+(Module       : out Module_Cache;
+Success      : out Boolean;
+Module_Name  :     String;
+Load_Address :     Address := Null_Address);
+--  Initialize Module
+procedure Close_Module (Module : in out Module_Cache);
+--  Finalize Module
+function Value (Item : System.Address) return String;
+--  Return the String contained in Item, up until the first NUL character
+pragma Warnings (Off, "*Add_Module_To_Cache*");
+procedure Add_Module_To_Cache (Module_Name : String);
+--  To be called by Build_Cache_For_All_Modules to add a new module to the
+--  list. May not be referenced.
+package Module_Name is
+procedure Build_Cache_For_All_Modules;
+--  Create the cache for all current modules
+function Get (Addr : access System.Address) return String;
+--  Returns the module name for the given address, Addr may be updated
+--  to be set relative to a shared library. This depends on the platform.
+--  Returns an empty string for the main executable.
+function Is_Supported return Boolean;
+pragma Inline (Is_Supported);
+--  Returns True if Module_Name is supported, so if the traceback is
+--  supported for shared libraries.
+end Module_Name;
+package body Module_Name is separate;
+function Executable_Name return String;
+--  Returns the executable name as reported by argv[0]. If gnat_argv not
+--  initialized or if argv[0] executable not found in path, function returns
+--  an empty string.
+function Get_Executable_Load_Address return System.Address;
+pragma Import
+(C,
+Get_Executable_Load_Address,
+"__gnat_get_executable_load_address");
+--  Get the load address of the executable, or Null_Address if not known
+procedure Hexa_Traceback
+(Traceback    :        Tracebacks_Array;
+Suppress_Hex :        Boolean;
+Res          : in out Bounded_String);
+--  Non-symbolic traceback (simply write addresses in hexa)
+procedure Symbolic_Traceback_No_Lock
+(Traceback    :        Tracebacks_Array;
+Suppress_Hex :        Boolean;
+Res          : in out Bounded_String);
+--  Like the public Symbolic_Traceback_No_Lock except there is no provision
+--  against concurrent accesses.
+procedure Module_Symbolic_Traceback
+(Traceback    :        Tracebacks_Array;
+Module       :        Module_Cache;
+Suppress_Hex :        Boolean;
+Res          : in out Bounded_String);
+--  Returns the Traceback for a given module
+procedure Multi_Module_Symbolic_Traceback
+(Traceback    :        Tracebacks_Array;
+Suppress_Hex :        Boolean;
+Res          : in out Bounded_String);
+--  Build string containing symbolic traceback for the given call chain
+procedure Multi_Module_Symbolic_Traceback
+(Traceback    :        Tracebacks_Array;
+Module       :        Module_Cache;
+Suppress_Hex :        Boolean;
+Res          : in out Bounded_String);
+--  Likewise but using Module
+Max_String_Length : constant := 4096;
+--  Arbitrary limit on Bounded_Str length
+-----------
+-- Value --
+-----------
+function Value (Item : System.Address) return String is
+begin
+if Item /= Null_Address then
+for J in Big_String'Range loop
+if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then
+return Big_String_Conv.To_Pointer (Item) (1 .. J - 1);
+end if;
+end loop;
+end if;
+return "";
+end Value;
+-------------------------
+-- Add_Module_To_Cache --
+-------------------------
+procedure Add_Module_To_Cache (Module_Name : String) is
+Module  : Module_Cache_Acc;
+Success : Boolean;
+begin
+Module := new Module_Cache;
+Init_Module (Module.all, Success, Module_Name);
+if not Success then
+Free (Module);
+return;
+end if;
+Module.Chain := Cache_Chain;
+Cache_Chain  := Module;
+end Add_Module_To_Cache;
+----------------------
+-- Init_Exec_Module --
+----------------------
+procedure Init_Exec_Module is
+begin
+if Exec_Module_State = Uninitialized then
+declare
+Exec_Path : constant String  := Executable_Name;
+Exec_Load : constant Address := Get_Executable_Load_Address;
+Success   : Boolean;
+begin
+Init_Module (Exec_Module, Success, Exec_Path, Exec_Load);
+if Success then
+Exec_Module_State := Initialized;
+else
+Exec_Module_State := Failed;
+end if;
+end;
+end if;
+end Init_Exec_Module;
+--------
+-- Lt --
+--------
+function Lt (Left, Right : Module_Cache_Acc) return Boolean is
+begin
+return Low (Left.C) < Low (Right.C);
+end Lt;
+-----------------------------
+-- Module_Cache_Array_Sort --
+-----------------------------
+procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort
+(Natural,
+Module_Cache_Acc,
+Module_Array,
+Lt);
+------------------
+-- Enable_Cache --
+------------------
+procedure Enable_Cache (Include_Modules : Boolean := False) is
+begin
+--  Can be called at most once
+if Cache_Chain /= null then
+return;
+end if;
+--  Add all modules
+Init_Exec_Module;
+Cache_Chain := Exec_Module'Access;
+if Include_Modules then
+Module_Name.Build_Cache_For_All_Modules;
+end if;
+--  Build and fill the array of modules
+declare
+Count  : Natural;
+Module : Module_Cache_Acc;
+begin
+for Phase in 1 .. 2 loop
+Count  := 0;
+Module := Cache_Chain;
+while Module /= null loop
+Count := Count + 1;
+if Phase = 1 then
+Enable_Cache (Module.C);
+else
+Modules_Cache (Count) := Module;
+end if;
+Module := Module.Chain;
+end loop;
+if Phase = 1 then
+Modules_Cache := new Module_Array (1 .. Count);
+end if;
+end loop;
+end;
+--  Sort the array
+Module_Cache_Array_Sort (Modules_Cache.all);
+end Enable_Cache;
+---------------------
+-- Executable_Name --
+---------------------
+function Executable_Name return String is
+--  We have to import gnat_argv as an Address to match the type of
+--  gnat_argv in the binder generated file. Otherwise, we get spurious
+--  warnings about type mismatch when LTO is turned on.
+Gnat_Argv : System.Address;
+pragma Import (C, Gnat_Argv, "gnat_argv");
+type Argv_Array is array (0 .. 0) of System.Address;
+package Conv is new System.Address_To_Access_Conversions (Argv_Array);
+function locate_exec_on_path (A : System.Address) return System.Address;
+pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path");
+begin
+if Gnat_Argv = Null_Address then
+return "";
+end if;
+declare
+Addr : constant System.Address :=
+locate_exec_on_path (Conv.To_Pointer (Gnat_Argv) (0));
+Result : constant String := Value (Addr);
+begin
+--  The buffer returned by locate_exec_on_path was allocated using
+--  malloc, so we should use free to release the memory.
+if Addr /= Null_Address then
+System.CRTL.free (Addr);
+end if;
+return Result;
+end;
+end Executable_Name;
+------------------
+-- Close_Module --
+------------------
+procedure Close_Module (Module : in out Module_Cache) is
+begin
+Close (Module.C);
+Strings.Free (Module.Name);
+end Close_Module;
+-----------------
+-- Init_Module --
+-----------------
+procedure Init_Module
+(Module       : out Module_Cache;
+Success      : out Boolean;
+Module_Name  :     String;
+Load_Address :     Address := Null_Address)
+is
+begin
+--  Early return if the module is not known
+if Module_Name = "" then
+Success := False;
+return;
+end if;
+Open (Module_Name, Module.C, Success);
+--  If a module can't be opened just return now, we just cannot give more
+--  information in this case.
+if not Success then
+return;
+end if;
+Set_Load_Address (Module.C, Load_Address);
+Module.Name := new String'(Module_Name);
+end Init_Module;
+-------------------------------
+-- Module_Symbolic_Traceback --
+-------------------------------
+procedure Module_Symbolic_Traceback
+(Traceback    :        Tracebacks_Array;
+Module       :        Module_Cache;
+Suppress_Hex :        Boolean;
+Res          : in out Bounded_String)
+is
+Success : Boolean := False;
+begin
+if Symbolic.Module_Name.Is_Supported then
+Append (Res, '[');
+Append (Res, Module.Name.all);
+Append (Res, ']' & ASCII.LF);
+end if;
+Dwarf_Lines.Symbolic_Traceback
+(Module.C,
+Traceback,
+Suppress_Hex,
+Success,
+Res);
+if not Success then
+Hexa_Traceback (Traceback, Suppress_Hex, Res);
+end if;
+--  We must not allow an unhandled exception here, since this function
+--  may be installed as a decorator for all automatic exceptions.
+exception
+when others =>
+return;
+end Module_Symbolic_Traceback;
+-------------------------------------
+-- Multi_Module_Symbolic_Traceback --
+-------------------------------------
+procedure Multi_Module_Symbolic_Traceback
+(Traceback    :        Tracebacks_Array;
+Suppress_Hex :        Boolean;
+Res          : in out Bounded_String)
+is
+F : constant Natural := Traceback'First;
+begin
+if Traceback'Length = 0 or else Is_Full (Res) then
+return;
+end if;
+if Modules_Cache /= null then
+--  Search in the cache
+declare
+Addr        : constant Address := Traceback (F);
+Hi, Lo, Mid : Natural;
+begin
+Lo := Modules_Cache'First;
+Hi := Modules_Cache'Last;
+while Lo <= Hi loop
+Mid := (Lo + Hi) / 2;
+if Addr < Low (Modules_Cache (Mid).C) then
+Hi := Mid - 1;
+elsif Is_Inside (Modules_Cache (Mid).C, Addr) then
+Multi_Module_Symbolic_Traceback
+(Traceback,
+Modules_Cache (Mid).all,
+Suppress_Hex,
+Res);
+return;
+else
+Lo := Mid + 1;
+end if;
+end loop;
+--  Not found
+Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
+Multi_Module_Symbolic_Traceback
+(Traceback (F + 1 .. Traceback'Last),
+Suppress_Hex,
+Res);
+end;
+else
+--  First try the executable
+if Is_Inside (Exec_Module.C, Traceback (F)) then
+Multi_Module_Symbolic_Traceback
+(Traceback,
+Exec_Module,
+Suppress_Hex,
+Res);
+return;
+end if;
+--  Otherwise, try a shared library
+declare
+Addr    : aliased System.Address := Traceback (F);
+M_Name  : constant String        := Module_Name.Get (Addr'Access);
+Module  : Module_Cache;
+Success : Boolean;
+begin
+Init_Module (Module, Success, M_Name, System.Null_Address);
+if Success then
+Multi_Module_Symbolic_Traceback
+(Traceback,
+Module,
+Suppress_Hex,
+Res);
+Close_Module (Module);
+else
+--  Module not found
+Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
+Multi_Module_Symbolic_Traceback
+(Traceback (F + 1 .. Traceback'Last),
+Suppress_Hex,
+Res);
+end if;
+end;
+end if;
+end Multi_Module_Symbolic_Traceback;
+procedure Multi_Module_Symbolic_Traceback
+(Traceback    :        Tracebacks_Array;
+Module       :        Module_Cache;
+Suppress_Hex :        Boolean;
+Res          : in out Bounded_String)
+is
+Pos : Positive;
+begin
+--  Will symbolize the first address...
+Pos := Traceback'First + 1;
+--  ... and all addresses in the same module
+Same_Module :
+loop
+exit Same_Module when Pos > Traceback'Last;
+--  Get address to check for corresponding module name
+exit Same_Module when not Is_Inside (Module.C, Traceback (Pos));
+Pos := Pos + 1;
+end loop Same_Module;
+Module_Symbolic_Traceback
+(Traceback (Traceback'First .. Pos - 1),
+Module,
+Suppress_Hex,
+Res);
+Multi_Module_Symbolic_Traceback
+(Traceback (Pos .. Traceback'Last),
+Suppress_Hex,
+Res);
+end Multi_Module_Symbolic_Traceback;
+--------------------
+-- Hexa_Traceback --
+--------------------
+procedure Hexa_Traceback
+(Traceback    :        Tracebacks_Array;
+Suppress_Hex :        Boolean;
+Res          : in out Bounded_String)
+is
+use System.Traceback_Entries;
+begin
+if Suppress_Hex then
+Append (Res, "...");
+Append (Res, ASCII.LF);
+else
+for J in Traceback'Range loop
+Append_Address (Res, PC_For (Traceback (J)));
+Append (Res, ASCII.LF);
+end loop;
+end if;
+end Hexa_Traceback;
+--------------------------------
+-- Symbolic_Traceback_No_Lock --
+--------------------------------
+procedure Symbolic_Traceback_No_Lock
+(Traceback    :        Tracebacks_Array;
+Suppress_Hex :        Boolean;
+Res          : in out Bounded_String)
+is
+begin
+if Symbolic.Module_Name.Is_Supported then
+Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res);
+else
+if Exec_Module_State = Failed then
+Append (Res, "Call stack traceback locations:" & ASCII.LF);
+Hexa_Traceback (Traceback, Suppress_Hex, Res);
+else
+Module_Symbolic_Traceback
+(Traceback,
+Exec_Module,
+Suppress_Hex,
+Res);
+end if;
+end if;
+end Symbolic_Traceback_No_Lock;
+------------------------
+-- Symbolic_Traceback --
+------------------------
+function Symbolic_Traceback
+(Traceback    : Tracebacks_Array;
+Suppress_Hex : Boolean) return String
+is
+Res : Bounded_String (Max_Length => Max_String_Length);
+begin
+System.Soft_Links.Lock_Task.all;
+Init_Exec_Module;
+Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res);
+System.Soft_Links.Unlock_Task.all;
+return To_String (Res);
+exception
+when others =>
+System.Soft_Links.Unlock_Task.all;
+raise;
+end Symbolic_Traceback;
+function Symbolic_Traceback
+(Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
+begin
+return Symbolic_Traceback (Traceback, Suppress_Hex => False);
+end Symbolic_Traceback;
+function Symbolic_Traceback_No_Hex
+(Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
+begin
+return Symbolic_Traceback (Traceback, Suppress_Hex => True);
+end Symbolic_Traceback_No_Hex;
+function Symbolic_Traceback
+(E            : Ada.Exceptions.Exception_Occurrence;
+Suppress_Hex : Boolean) return String
+is
+begin
+return Symbolic_Traceback
+(Ada.Exceptions.Traceback.Tracebacks (E),
+Suppress_Hex);
+end Symbolic_Traceback;
+function Symbolic_Traceback
+(E : Ada.Exceptions.Exception_Occurrence) return String
+is
+begin
+return Symbolic_Traceback (E, Suppress_Hex => False);
+end Symbolic_Traceback;
+function Symbolic_Traceback_No_Hex
+(E : Ada.Exceptions.Exception_Occurrence) return String is
+begin
+return Symbolic_Traceback (E, Suppress_Hex => True);
+end Symbolic_Traceback_No_Hex;
+Exception_Tracebacks_Symbolic : Integer;
+pragma Import
+(C,
+Exception_Tracebacks_Symbolic,
+"__gl_exception_tracebacks_symbolic");
+--  Boolean indicating whether symbolic tracebacks should be generated.
+use Standard_Library;
+begin
+--  If this version of this package is available, and the binder switch -Es
+--  was given, then we want to use this as the decorator by default, and we
+--  want to turn on tracing for Unhandled_Raise_In_Main. Note that the user
+--  cannot have already set Exception_Trace, because the runtime library is
+--  elaborated before user-defined code.
+if Exception_Tracebacks_Symbolic /= 0 then
+Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access);
+pragma Assert (Exception_Trace = RM_Convention);
+Exception_Trace := Unhandled_Raise_In_Main;
+end if;
+end System.Traceback.Symbolic;

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/s-trasym__dwarf.adb @ 111:04ced10e8804