Subversion Repositories openrisc

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

--                                                                          --

--                         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                --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--         Copyright (C) 2005-2010, 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.      --

--                                                                          --

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

--  Run-time symbolic traceback support for IA64/VMS

with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;

with System;

with System.Aux_DEC;

with System.Soft_Links;

with System.Traceback_Entries;

package body GNAT.Traceback.Symbolic is

   use System;

   use System.Aux_DEC;

   use System.Traceback_Entries;

   subtype Var_String_Buf is String (1 .. 254);

   type Var_String is record

      Curlen : Unsigned_Word := 0;

      Buf    : Var_String_Buf;

   end record;

   pragma Convention (C, Var_String);

   for Var_String'Size use 8 * 256;

   type Descriptor64 is record

      Mbo       : Unsigned_Word;

      Dtype     : Unsigned_Byte;

      Class     : Unsigned_Byte;

      Mbmo      : Unsigned_Longword;

      Maxstrlen : Integer_64;

      Pointer   : Address;

   end record;

   pragma Convention (C, Descriptor64);

   subtype Cond_Value_Type is Unsigned_Longword;

   --  TBK_API_PARAM as defined in TBKDEF

   type Tbk_Api_Param is record

      Length              : Unsigned_Word;

      T_Type              : Unsigned_Byte;

      Version             : Unsigned_Byte;

      Reserveda           : Unsigned_Longword;

      Faulting_Pc         : Address;

      Faulting_Fp         : Address;

      Filename_Desc       : Address;

      Library_Module_Desc : Address;

      Record_Number       : Address;

      Image_Desc          : Address;

      Module_Desc         : Address;

      Routine_Desc        : Address;

      Listing_Lineno      : Address;

      Rel_Pc              : Address;

      Image_Base_Addr     : Address;

      Module_Base_Addr    : Address;

      Malloc_Rtn          : Address;

      Free_Rtn            : Address;

      Symbolize_Flags     : Address;

      Reserved0           : Unsigned_Quadword;

      Reserved1           : Unsigned_Quadword;

      Reserved2           : Unsigned_Quadword;

   end record;

   pragma Convention (C, Tbk_Api_Param);

   K_Version : constant Unsigned_Byte := 1;

   --  Current API version

   K_Length : constant Unsigned_Word := 152;

   --  Length of the parameter

   pragma Compile_Time_Error (Tbk_Api_Param'Size = K_Length * 8,

                              "Bad length for tbk_api_param");

   --  Sanity check

   function Symbolize (Param : Address) return Cond_Value_Type;

   pragma Import (C, Symbolize, "TBK$I64_SYMBOLIZE");

   function Decode_Ada_Name (Encoded_Name : String) return String;

   --  Decodes an Ada identifier name. Removes leading "_ada_" and trailing

   --  __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'

   procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address);

   --  Setup descriptor Desc for address Var

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

   -- Decode_Ada_Name --

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

   function Decode_Ada_Name (Encoded_Name : String) return String is

      Decoded_Name : String (1 .. Encoded_Name'Length);

      Pos          : Integer := Encoded_Name'First;

      Last         : Integer := Encoded_Name'Last;

      DPos         : Integer := 1;

   begin

      if Pos > Last then

         return "";

      end if;

      --  Skip leading _ada_

      if Encoded_Name'Length > 4

        and then Encoded_Name (Pos .. Pos + 4) = "_ada_"

      then

         Pos := Pos + 5;

      end if;

      --  Skip trailing __{DIGIT}+ or ${DIGIT}+

      if Encoded_Name (Last) in '0' .. '9' then

         for J in reverse Pos + 2 .. Last - 1 loop

            case Encoded_Name (J) is

               when '0' .. '9' =>

                  null;

               when '$' =>

                  Last := J - 1;

                  exit;

               when '_' =>

                  if Encoded_Name (J - 1) = '_' then

                     Last := J - 2;

                  end if;

                  exit;

               when others =>

                  exit;

            end case;

         end loop;

      end if;

      --  Now just copy encoded name to decoded name, converting "__" to '.'

      while Pos <= Last loop

         if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_'

           and then Pos /= Encoded_Name'First

         then

            Decoded_Name (DPos) := '.';

            Pos := Pos + 2;

         else

            Decoded_Name (DPos) := Encoded_Name (Pos);

            Pos := Pos + 1;

         end if;

         DPos := DPos + 1;

      end loop;

      return Decoded_Name (1 .. DPos - 1);

   end Decode_Ada_Name;

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

   -- Setup_Descriptor64_Vs --

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

   procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address) is

      K_Dtype_Vt : constant Unsigned_Byte := 37;

      K_Class_Vs : constant Unsigned_Byte := 11;

   begin

      Desc.Mbo := 1;

      Desc.Dtype := K_Dtype_Vt;

      Desc.Class := K_Class_Vs;

      Desc.Mbmo := -1;

      Desc.Maxstrlen := Integer_64 (Var_String_Buf'Length);

      Desc.Pointer := Var;

   end Setup_Descriptor64_Vs;

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

   -- Symbolic_Traceback --

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

   function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is

      Param         : Tbk_Api_Param;

      Status        : Cond_Value_Type;

      Record_Number : Unsigned_Longword;

      Image_Name    : Var_String;

      Image_Dsc     : Descriptor64;

      Module_Name   : Var_String;

      Module_Dsc    : Descriptor64;

      Routine_Name  : Var_String;

      Routine_Dsc   : Descriptor64;

      Line_Number   : Unsigned_Longword;

      Res           : String (1 .. 256 * Traceback'Length);

      Len           : Integer;

   begin

      if Traceback'Length = 0 then

         return "";

      end if;

      Len := 0;

      --  Since image computation is not thread-safe we need task lockout

      System.Soft_Links.Lock_Task.all;

      --  Initialize descriptors

      Setup_Descriptor64_Vs (Image_Dsc, Image_Name'Address);

      Setup_Descriptor64_Vs (Module_Dsc, Module_Name'Address);

      Setup_Descriptor64_Vs (Routine_Dsc, Routine_Name'Address);

      for J in Traceback'Range loop

         --  Initialize fields in case they are not written

         Record_Number := 0;

         Line_Number := 0;

         Image_Name.Curlen := 0;

         Module_Name.Curlen := 0;

         Routine_Name.Curlen := 0;

         --  Symbolize

         Param := (Length              => K_Length,

                   T_Type              => 0,

                   Version             => K_Version,

                   Reserveda           => 0,

                   Faulting_Pc         => PC_For (Traceback (J)),

                   Faulting_Fp         => 0,

                   Filename_Desc       => Null_Address,

                   Library_Module_Desc => Null_Address,

                   Record_Number       => Record_Number'Address,

                   Image_Desc          => Image_Dsc'Address,

                   Module_Desc         => Module_Dsc'Address,

                   Routine_Desc        => Routine_Dsc'Address,

                   Listing_Lineno      => Line_Number'Address,

                   Rel_Pc              => Null_Address,

                   Image_Base_Addr     => Null_Address,

                   Module_Base_Addr    => Null_Address,

                   Malloc_Rtn          => Null_Address,

                   Free_Rtn            => Null_Address,

                   Symbolize_Flags     => Null_Address,

                   Reserved0           => (0, 0),

                   Reserved1           => (0, 0),

                   Reserved2           => (0, 0));

         Status := Symbolize (Param'Address);

         --  Check for success (marked by bit 0)

         if (Status rem 2) = 1 then

            --  Success

            if Line_Number = 0 then

               --  As GCC doesn't emit source file correlation, use record

               --  number of line number is not set

               Line_Number := Record_Number;

            end if;

            declare

               First : constant Integer := Len + 1;

               Last  : Integer := First + 80 - 1;

               Pos   : Integer;

               Routine_Name_D : constant String :=

                                  Decode_Ada_Name

                                    (Routine_Name.Buf

                                      (1 .. Natural (Routine_Name.Curlen)));

               Lineno : constant String :=

                          Unsigned_Longword'Image (Line_Number);

            begin

               Res (First .. Last) := (others => ' ');

               Res (First .. First + Natural (Image_Name.Curlen) - 1) :=

                 Image_Name.Buf (1 .. Natural (Image_Name.Curlen));

               Res (First + 10 ..

                      First + 10 + Natural (Module_Name.Curlen) - 1) :=

                 Module_Name.Buf (1 .. Natural (Module_Name.Curlen));

               Res (First + 30 ..

                      First + 30 + Routine_Name_D'Length - 1) :=

                 Routine_Name_D;

               --  If routine name doesn't fit 20 characters, output the line

               --  number on next line at 50th position.

               if Routine_Name_D'Length > 20 then

                  Pos := First + 30 + Routine_Name_D'Length;

                  Res (Pos) := ASCII.LF;

                  Last := Pos + 80;

                  Res (Pos + 1 .. Last) := (others => ' ');

                  Pos := Pos + 51;

               else

                  Pos := First + 50;

               end if;

               Res (Pos .. Pos + Lineno'Length - 1) := Lineno;

               Res (Last) := ASCII.LF;

               Len := Last;

            end;

         --  Failure (bit 0 clear)

         else

            Res (Len + 1 .. Len + 6) := "ERROR" & ASCII.LF;

            Len := Len + 6;

         end if;

      end loop;

      System.Soft_Links.Unlock_Task.all;

      return Res (1 .. Len);

   end Symbolic_Traceback;

   function Symbolic_Traceback (E : Exception_Occurrence) return String is

   begin

      return Symbolic_Traceback (Tracebacks (E));

   end Symbolic_Traceback;

end GNAT.Traceback.Symbolic;