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
34with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
35with System;
36with System.Aux_DEC;
37with System.Soft_Links;
38with System.Traceback_Entries;
39
40package 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
345end GNAT.Traceback.Symbolic;
346