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