Subversion Repositories openrisc_2011-10-31

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                           V X A D D R 2 L I N E                          --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--                     Copyright (C) 2002-2009, 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.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

--  This program is meant to be used with vxworks to compute symbolic

--  backtraces on the host from non-symbolic backtraces obtained on the target.

--  The basic idea is to automate the computation of the necessary address

--  adjustments prior to calling addr2line when the application has only been

--  partially linked on the host.

--  Variants for various targets are supported, and the command line should

--  be like :

--  <target>-addr2line [-a <target_arch>] <exe_file> <ref_address>

--                     <backtrace addresses>

--  Where:

--  <target_arch> :

--    selects the target architecture. In the absence of this parameter the

--    default variant is chosen based on the Detect_Arch result. Generally,

--    this parameter will only be used if vxaddr2line is recompiled manually.

--    Otherwise, the command name will always be of the form

--    <target>-vxaddr2line where there is no ambiguity on the target's

--    architecture.

--  <exe_file> :

--    The name of the partially linked binary file for the application.

--  <ref_address> :

--    Runtime address (on the target) of a reference symbol you choose,

--    which name shall match the value of the Ref_Symbol variable declared

--    below. A symbol with a small offset from the beginning of the text

--    segment is better, so "adainit" is a good choice.

--  <backtrace addresses> :

--    The call chain addresses you obtained at run time on the target and

--    for which you want a symbolic association.

--  TO ADD A NEW ARCHITECTURE add an appropriate value to Architecture type

--  (in a format <host>_<target>), and then an appropriate value to Config_List

--  array

with Ada.Text_IO;       use Ada.Text_IO;

with Ada.Command_Line;  use Ada.Command_Line;

with Ada.Strings.Fixed; use Ada.Strings.Fixed;

with Interfaces;        use Interfaces;

with GNAT.OS_Lib;               use GNAT.OS_Lib;

with GNAT.Directory_Operations; use GNAT.Directory_Operations;

with GNAT.Expect;               use GNAT.Expect;

with GNAT.Regpat;               use GNAT.Regpat;

procedure VxAddr2Line is

   package Unsigned_32_IO is new Modular_IO (Unsigned_32);

   --  Instantiate Modular_IO to have Put

   Ref_Symbol : constant String := "adainit";

   --  This is the name of the reference symbol which runtime address shall

   --  be provided as the <ref_address> argument.

   --  All supported architectures

   type Architecture is

     (SOLARIS_I586,

      WINDOWS_POWERPC,

      WINDOWS_I586,

      WINDOWS_M68K,

      SOLARIS_POWERPC,

      DEC_ALPHA);

   type Arch_Record is record

      Addr2line_Binary : String_Access;

      --  Name of the addr2line utility to use

      Nm_Binary : String_Access;

      --  Name of the host nm utility, which will be used to find out the

      --  offset of the reference symbol in the text segment of the partially

      --  linked executable.

      Addr_Digits_To_Skip : Integer;

      --  When addresses such as 0xfffffc0001dfed50 are provided, for instance

      --  on ALPHA, indicate the number of leading digits that can be ignored,

      --  which will avoid computational overflows. Typically only useful when

      --  64bit addresses are provided.

      Bt_Offset_From_Call : Unsigned_32;

      --  Offset from a backtrace address to the address of the corresponding

      --  call instruction. This should always be 0, except on platforms where

      --  the backtrace addresses actually correspond to return and not call

      --  points. In such cases, a negative value is most likely.

   end record;

   --  Configuration for each of the architectures

   Arch_List : array (Architecture'Range) of Arch_Record :=

     (WINDOWS_POWERPC =>

        (Addr2line_Binary    => null,

         Nm_Binary           => null,

         Addr_Digits_To_Skip => 0,

         Bt_Offset_From_Call => -4),

      WINDOWS_M68K =>

        (Addr2line_Binary    => null,

         Nm_Binary           => null,

         Addr_Digits_To_Skip => 0,

         Bt_Offset_From_Call => -4),

      WINDOWS_I586 =>

        (Addr2line_Binary    => null,

         Nm_Binary           => null,

         Addr_Digits_To_Skip => 0,

         Bt_Offset_From_Call => -2),

      SOLARIS_POWERPC =>

        (Addr2line_Binary    => null,

         Nm_Binary           => null,

         Addr_Digits_To_Skip => 0,

         Bt_Offset_From_Call => 0),

      SOLARIS_I586 =>

        (Addr2line_Binary    => null,

         Nm_Binary           => null,

         Addr_Digits_To_Skip => 0,

         Bt_Offset_From_Call => -2),

      DEC_ALPHA =>

        (Addr2line_Binary    => null,

         Nm_Binary           => null,

         Addr_Digits_To_Skip => 8,

         Bt_Offset_From_Call => 0)

     );

   --  Current architecture

   Cur_Arch : Architecture;

   --  State of architecture detection

   Detect_Success : Boolean := False;

   -----------------------

   -- Local subprograms --

   -----------------------

   procedure Error (Msg : String);

   pragma No_Return (Error);

   --  Prints the message and then terminates the program

   procedure Usage;

   --  Displays the short help message and then terminates the program

   function Get_Reference_Offset return Unsigned_32;

   --  Computes the static offset of the reference symbol by calling nm

   function Get_Value_From_Hex_Arg (Arg : Natural) return Unsigned_32;

   --  Threats the argument number Arg as a C-style hexadecimal literal

   --  and returns its integer value

   function Hex_Image (Value : Unsigned_32) return String_Access;

   --  Returns access to a string that contains hexadecimal image of Value

   --  Separate functions that provide build-time customization:

   procedure Detect_Arch;

   --  Saves in Cur_Arch the current architecture, based on the name of

   --  vxaddr2line instance and properties of the host. Detect_Success is False

   --  if detection fails

   -----------------

   -- Detect_Arch --

   -----------------

   procedure Detect_Arch is

      Name   : constant String := Base_Name (Command_Name);

      Proc   : constant String :=

                 Name (Name'First .. Index (Name, "-") - 1);

      Target : constant String :=

                 Name (Name'First .. Index (Name, "vxaddr2line") - 1);

   begin

      Detect_Success := False;

      if Proc = "" then

         return;

      end if;

      if Proc = "alpha" then

         Cur_Arch := DEC_ALPHA;

      else

         --  Let's detect the host.

         --  ??? A naive implementation that can't distinguish between Unixes

         if Directory_Separator = '/' then

            Cur_Arch := Architecture'Value ("solaris_" & Proc);

         else

            Cur_Arch := Architecture'Value ("windows_" & Proc);

         end if;

      end if;

      if Arch_List (Cur_Arch).Addr2line_Binary = null then

         Arch_List (Cur_Arch).Addr2line_Binary := new String'

           (Target & "addr2line");

      end if;

      if Arch_List (Cur_Arch).Nm_Binary = null then

         Arch_List (Cur_Arch).Nm_Binary := new String'

           (Target & "nm");

      end if;

      Detect_Success := True;

   exception

      when others =>

         return;

   end Detect_Arch;

   -----------

   -- Error --

   -----------

   procedure Error (Msg : String) is

   begin

      Put_Line (Msg);

      OS_Exit (1);

      raise Program_Error;

   end Error;

   --------------------------

   -- Get_Reference_Offset --

   --------------------------

   function Get_Reference_Offset return Unsigned_32 is

      Nm_Cmd  : constant String_Access :=

                  Locate_Exec_On_Path (Arch_List (Cur_Arch).Nm_Binary.all);

      Nm_Args : constant Argument_List :=

                  (new String'("-P"),

                   new String'(Argument (1)));

      Forever   : aliased String := "^@@@@";

      Reference : aliased String := Ref_Symbol & "\s+\S\s+([\da-fA-F]+)";

      Pd     : Process_Descriptor;

      Result : Expect_Match;

   begin

      --  If Nm is not found, abort

      if Nm_Cmd = null then

         Error ("Couldn't find " & Arch_List (Cur_Arch).Nm_Binary.all);

      end if;

      Non_Blocking_Spawn

        (Pd, Nm_Cmd.all, Nm_Args, Buffer_Size => 0, Err_To_Out => True);

      --  Expect a string containing the reference symbol

      Expect (Pd, Result,

              Regexp_Array'(1 => Reference'Unchecked_Access),

              Timeout => -1);

      --  If we are here, the pattern was matched successfully

      declare

         Match_String : constant String := Expect_Out_Match (Pd);

         Matches      : Match_Array (0 .. 1);

         Value        : Unsigned_32;

      begin

         Match (Reference, Match_String, Matches);

         Value := Unsigned_32'Value

           ("16#"

            & Match_String (Matches (1).First .. Matches (1).Last) & "#");

         --  Expect a string that will never be emitted, so that the

         --  process can be correctly terminated (with Process_Died)

         Expect (Pd, Result,

                 Regexp_Array'(1 => Forever'Unchecked_Access),

                 Timeout => -1);

      exception

         when Process_Died =>

            return Value;

      end;

      --  We cannot get here

      raise Program_Error;

   exception

      when Invalid_Process =>

         Error ("Could not spawn a process " & Nm_Cmd.all);

      when others    =>

         --  The process died without matching the reference symbol or the

         --  format wasn't recognized.

         Error ("Unexpected output from " & Nm_Cmd.all);

   end Get_Reference_Offset;

   ----------------------------

   -- Get_Value_From_Hex_Arg --

   ----------------------------

   function Get_Value_From_Hex_Arg (Arg : Natural) return Unsigned_32 is

      Cur_Arg : constant String := Argument (Arg);

      Offset  : Natural;

   begin

      --  Skip "0x" prefix if present

      if Cur_Arg'Length > 2 and then Cur_Arg (1 .. 2) = "0x" then

         Offset := 3;

      else

         Offset := 1;

      end if;

      --  Add architecture-specific offset

      Offset := Offset + Arch_List (Cur_Arch).Addr_Digits_To_Skip;

      --  Convert to value

      return Unsigned_32'Value

        ("16#" & Cur_Arg (Offset .. Cur_Arg'Last) & "#");

   exception

      when Constraint_Error =>

         Error ("Can't parse backtrace address '" & Cur_Arg & "'");

         raise;

   end Get_Value_From_Hex_Arg;

   ---------------

   -- Hex_Image --

   ---------------

   function Hex_Image (Value : Unsigned_32) return String_Access is

      Result    : String (1 .. 20);

      Start_Pos : Natural;

   begin

      Unsigned_32_IO.Put (Result, Value, 16);

      Start_Pos := Index (Result, "16#") + 3;

      return new String'(Result (Start_Pos .. Result'Last - 1));

   end Hex_Image;

   -----------

   -- Usage --

   -----------

   procedure Usage is

   begin

      Put_Line ("Usage : " & Base_Name (Command_Name)

                & " <executable> <"

                & Ref_Symbol & " offset on target> <addr1> ...");

      OS_Exit (1);

   end Usage;

   Ref_Static_Offset, Ref_Runtime_Address, Bt_Address : Unsigned_32;

   Addr2line_Cmd : String_Access;

   Addr2line_Args : Argument_List (1 .. 501);

   --  We expect that there won't be more than 500 backtrace frames

   Addr2line_Args_Count : Natural;

   Success : Boolean;

--  Start of processing for VxAddr2Line

begin

   Detect_Arch;

   --  There should be at least two arguments

   if Argument_Count < 2 then

      Usage;

   end if;

   --  ??? HARD LIMIT! There should be at most 501 arguments

   if Argument_Count > 501 then

      Error ("Too many backtrace frames");

   end if;

   --  Do we have a valid architecture?

   if not Detect_Success then

      Put_Line ("Couldn't detect the architecture");

      return;

   end if;

   Addr2line_Cmd :=

     Locate_Exec_On_Path (Arch_List (Cur_Arch).Addr2line_Binary.all);

   --  If Addr2line is not found, abort

   if Addr2line_Cmd = null then

      Error ("Couldn't find " & Arch_List (Cur_Arch).Addr2line_Binary.all);

   end if;

   --  The first argument specifies the image file. Check if it exists

   if not Is_Regular_File (Argument (1)) then

      Error ("Couldn't find the executable " & Argument (1));

   end if;

   --  The second argument specifies the reference symbol runtime address.

   --  Let's parse and store it

   Ref_Runtime_Address := Get_Value_From_Hex_Arg (2);

   --  Run nm command to get the reference symbol static offset

   Ref_Static_Offset := Get_Reference_Offset;

   --  Build addr2line parameters. First, the standard part

   Addr2line_Args (1) := new String'("--exe=" & Argument (1));

   Addr2line_Args_Count := 1;

   --  Now, append to this the adjusted backtraces in arguments 4 and further

   for J in 3 .. Argument_Count loop

      --  Basically, for each address in the runtime backtrace ...

      --  o We compute its offset relatively to the runtime address of the

      --    reference symbol,

      --  and then ...

      --  o We add this offset to the static one for the reference symbol in

      --    the executable to find the executable offset corresponding to the

      --    backtrace address.

      Bt_Address := Get_Value_From_Hex_Arg (J);

      Bt_Address :=

        Bt_Address - Ref_Runtime_Address

                   + Ref_Static_Offset

                   + Arch_List (Cur_Arch).Bt_Offset_From_Call;

      Addr2line_Args_Count := Addr2line_Args_Count + 1;

      Addr2line_Args (Addr2line_Args_Count) := Hex_Image (Bt_Address);

   end loop;

   --  Run the resulting command

   Spawn (Addr2line_Cmd.all,

          Addr2line_Args (1 .. Addr2line_Args_Count), Success);

   if not Success then

      Error ("Couldn't spawn " & Addr2line_Cmd.all);

   end if;

exception

   when others =>

      --  Mask all exceptions

      return;

end VxAddr2Line;