gcc/ada/g-trasym-vms-ia64.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                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --         Copyright (C) 2005-2010, Free Software Foundation, Inc.          --
  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 --  Run-time symbolic traceback support for IA64/VMS
  33
  34 with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
  35 with System;
  36 with System.Aux_DEC;
  37 with System.Soft_Links;
  38 with System.Traceback_Entries;
  39
  40 package body GNAT.Traceback.Symbolic is
  41
  42    use System;
  43    use System.Aux_DEC;
  44    use System.Traceback_Entries;
  45
  46    subtype Var_String_Buf is String (1 .. 254);
  47
  48    type Var_String is record
  49       Curlen : Unsigned_Word := 0;
  50       Buf    : Var_String_Buf;
  51    end record;
  52    pragma Convention (C, Var_String);
  53    for Var_String'Size use 8 * 256;
  54
  55    type Descriptor64 is record
  56       Mbo       : Unsigned_Word;
  57       Dtype     : Unsigned_Byte;
  58       Class     : Unsigned_Byte;
  59       Mbmo      : Unsigned_Longword;
  60       Maxstrlen : Integer_64;
  61       Pointer   : Address;
  62    end record;
  63    pragma Convention (C, Descriptor64);
  64
  65    subtype Cond_Value_Type is Unsigned_Longword;
  66
  67    --  TBK_API_PARAM as defined in TBKDEF
  68
  69    type Tbk_Api_Param is record
  70       Length              : Unsigned_Word;
  71       T_Type              : Unsigned_Byte;
  72       Version             : Unsigned_Byte;
  73       Reserveda           : Unsigned_Longword;
  74       Faulting_Pc         : Address;
  75       Faulting_Fp         : Address;
  76       Filename_Desc       : Address;
  77       Library_Module_Desc : Address;
  78       Record_Number       : Address;
  79       Image_Desc          : Address;
  80       Module_Desc         : Address;
  81       Routine_Desc        : Address;
  82       Listing_Lineno      : Address;
  83       Rel_Pc              : Address;
  84       Image_Base_Addr     : Address;
  85       Module_Base_Addr    : Address;
  86       Malloc_Rtn          : Address;
  87       Free_Rtn            : Address;
  88       Symbolize_Flags     : Address;
  89       Reserved0           : Unsigned_Quadword;
  90       Reserved1           : Unsigned_Quadword;
  91       Reserved2           : Unsigned_Quadword;
  92    end record;
  93    pragma Convention (C, Tbk_Api_Param);
  94
  95    K_Version : constant Unsigned_Byte := 1;
  96    --  Current API version
  97
  98    K_Length : constant Unsigned_Word := 152;
  99    --  Length of the parameter
 100
 101    pragma Compile_Time_Error (Tbk_Api_Param'Size = K_Length * 8,
 102                               "Bad length for tbk_api_param");
 103    --  Sanity check
 104
 105    function Symbolize (Param : Address) return Cond_Value_Type;
 106    pragma Import (C, Symbolize, "TBK$I64_SYMBOLIZE");
 107
 108    function Decode_Ada_Name (Encoded_Name : String) return String;
 109    --  Decodes an Ada identifier name. Removes leading "_ada_" and trailing
 110    --  __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'
 111
 112    procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address);
 113    --  Setup descriptor Desc for address Var
 114
 115    ---------------------
 116    -- Decode_Ada_Name --
 117    ---------------------
 118
 119    function Decode_Ada_Name (Encoded_Name : String) return String is
 120       Decoded_Name : String (1 .. Encoded_Name'Length);
 121       Pos          : Integer := Encoded_Name'First;
 122       Last         : Integer := Encoded_Name'Last;
 123       DPos         : Integer := 1;
 124
 125    begin
 126       if Pos > Last then
 127          return "";
 128       end if;
 129
 130       --  Skip leading _ada_
 131
 132       if Encoded_Name'Length > 4
 133         and then Encoded_Name (Pos .. Pos + 4) = "_ada_"
 134       then
 135          Pos := Pos + 5;
 136       end if;
 137
 138       --  Skip trailing __{DIGIT}+ or ${DIGIT}+
 139
 140       if Encoded_Name (Last) in '0' .. '9' then
 141          for J in reverse Pos + 2 .. Last - 1 loop
 142             case Encoded_Name (J) is
 143                when '0' .. '9' =>
 144                   null;
 145
 146                when '$' =>
 147                   Last := J - 1;
 148                   exit;
 149
 150                when '_' =>
 151                   if Encoded_Name (J - 1) = '_' then
 152                      Last := J - 2;
 153                   end if;
 154                   exit;
 155
 156                when others =>
 157                   exit;
 158             end case;
 159          end loop;
 160       end if;
 161
 162       --  Now just copy encoded name to decoded name, converting "__" to '.'
 163
 164       while Pos <= Last loop
 165          if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_'
 166            and then Pos /= Encoded_Name'First
 167          then
 168             Decoded_Name (DPos) := '.';
 169             Pos := Pos + 2;
 170          else
 171             Decoded_Name (DPos) := Encoded_Name (Pos);
 172             Pos := Pos + 1;
 173          end if;
 174
 175          DPos := DPos + 1;
 176       end loop;
 177
 178       return Decoded_Name (1 .. DPos - 1);
 179    end Decode_Ada_Name;
 180
 181    ---------------------------
 182    -- Setup_Descriptor64_Vs --
 183    ---------------------------
 184
 185    procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address) is
 186       K_Dtype_Vt : constant Unsigned_Byte := 37;
 187       K_Class_Vs : constant Unsigned_Byte := 11;
 188    begin
 189       Desc.Mbo := 1;
 190       Desc.Dtype := K_Dtype_Vt;
 191       Desc.Class := K_Class_Vs;
 192       Desc.Mbmo := -1;
 193       Desc.Maxstrlen := Integer_64 (Var_String_Buf'Length);
 194       Desc.Pointer := Var;
 195    end Setup_Descriptor64_Vs;
 196
 197    ------------------------
 198    -- Symbolic_Traceback --
 199    ------------------------
 200
 201    function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
 202       Param         : Tbk_Api_Param;
 203       Status        : Cond_Value_Type;
 204       Record_Number : Unsigned_Longword;
 205       Image_Name    : Var_String;
 206       Image_Dsc     : Descriptor64;
 207       Module_Name   : Var_String;
 208       Module_Dsc    : Descriptor64;
 209       Routine_Name  : Var_String;
 210       Routine_Dsc   : Descriptor64;
 211       Line_Number   : Unsigned_Longword;
 212       Res           : String (1 .. 256 * Traceback'Length);
 213       Len           : Integer;
 214
 215    begin
 216       if Traceback'Length = 0 then
 217          return "";
 218       end if;
 219
 220       Len := 0;
 221
 222       --  Since image computation is not thread-safe we need task lockout
 223
 224       System.Soft_Links.Lock_Task.all;
 225
 226       --  Initialize descriptors
 227
 228       Setup_Descriptor64_Vs (Image_Dsc, Image_Name'Address);
 229       Setup_Descriptor64_Vs (Module_Dsc, Module_Name'Address);
 230       Setup_Descriptor64_Vs (Routine_Dsc, Routine_Name'Address);
 231
 232       for J in Traceback'Range loop
 233          --  Initialize fields in case they are not written
 234
 235          Record_Number := 0;
 236          Line_Number := 0;
 237          Image_Name.Curlen := 0;
 238          Module_Name.Curlen := 0;
 239          Routine_Name.Curlen := 0;
 240
 241          --  Symbolize
 242
 243          Param := (Length              => K_Length,
 244                    T_Type              => 0,
 245                    Version             => K_Version,
 246                    Reserveda           => 0,
 247                    Faulting_Pc         => PC_For (Traceback (J)),
 248                    Faulting_Fp         => 0,
 249                    Filename_Desc       => Null_Address,
 250                    Library_Module_Desc => Null_Address,
 251                    Record_Number       => Record_Number'Address,
 252                    Image_Desc          => Image_Dsc'Address,
 253                    Module_Desc         => Module_Dsc'Address,
 254                    Routine_Desc        => Routine_Dsc'Address,
 255                    Listing_Lineno      => Line_Number'Address,
 256                    Rel_Pc              => Null_Address,
 257                    Image_Base_Addr     => Null_Address,
 258                    Module_Base_Addr    => Null_Address,
 259                    Malloc_Rtn          => Null_Address,
 260                    Free_Rtn            => Null_Address,
 261                    Symbolize_Flags     => Null_Address,
 262                    Reserved0           => (0, 0),
 263                    Reserved1           => (0, 0),
 264                    Reserved2           => (0, 0));
 265
 266          Status := Symbolize (Param'Address);
 267
 268          --  Check for success (marked by bit 0)
 269
 270          if (Status rem 2) = 1 then
 271
 272             --  Success
 273
 274             if Line_Number = 0 then
 275
 276                --  As GCC doesn't emit source file correlation, use record
 277                --  number of line number is not set
 278
 279                Line_Number := Record_Number;
 280             end if;
 281
 282             declare
 283                First : constant Integer := Len + 1;
 284                Last  : Integer := First + 80 - 1;
 285                Pos   : Integer;
 286
 287                Routine_Name_D : constant String :=
 288                                   Decode_Ada_Name
 289                                     (Routine_Name.Buf
 290                                       (1 .. Natural (Routine_Name.Curlen)));
 291
 292                Lineno : constant String :=
 293                           Unsigned_Longword'Image (Line_Number);
 294
 295             begin
 296                Res (First .. Last) := (others => ' ');
 297
 298                Res (First .. First + Natural (Image_Name.Curlen) - 1) :=
 299                  Image_Name.Buf (1 .. Natural (Image_Name.Curlen));
 300
 301                Res (First + 10 ..
 302                       First + 10 + Natural (Module_Name.Curlen) - 1) :=
 303                  Module_Name.Buf (1 .. Natural (Module_Name.Curlen));
 304
 305                Res (First + 30 ..
 306                       First + 30 + Routine_Name_D'Length - 1) :=
 307                  Routine_Name_D;
 308
 309                --  If routine name doesn't fit 20 characters, output the line
 310                --  number on next line at 50th position.
 311
 312                if Routine_Name_D'Length > 20 then
 313                   Pos := First + 30 + Routine_Name_D'Length;
 314                   Res (Pos) := ASCII.LF;
 315                   Last := Pos + 80;
 316                   Res (Pos + 1 .. Last) := (others => ' ');
 317                   Pos := Pos + 51;
 318                else
 319                   Pos := First + 50;
 320                end if;
 321
 322                Res (Pos .. Pos + Lineno'Length - 1) := Lineno;
 323
 324                Res (Last) := ASCII.LF;
 325                Len := Last;
 326             end;
 327
 328          --  Failure (bit 0 clear)
 329
 330          else
 331             Res (Len + 1 .. Len + 6) := "ERROR" & ASCII.LF;
 332             Len := Len + 6;
 333          end if;
 334       end loop;
 335
 336       System.Soft_Links.Unlock_Task.all;
 337       return Res (1 .. Len);
 338    end Symbolic_Traceback;
 339
 340    function Symbolic_Traceback (E : Exception_Occurrence) return String is
 341    begin
 342       return Symbolic_Traceback (Tracebacks (E));
 343    end Symbolic_Traceback;
 344
 345 end GNAT.Traceback.Symbolic;