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