1-- GHDL Run Time (GRT) - Backtraces and symbolization. 2-- Copyright (C) 2015 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16-- 17-- As a special exception, if other files instantiate generics from this 18-- unit, or you link this unit with other files to produce an executable, 19-- this unit does not by itself cause the resulting executable to be 20-- covered by the GNU General Public License. This exception does not 21-- however invalidate any other reasons why the executable file might be 22-- covered by the GNU Public License. 23 24with System; 25with Grt.Types; use Grt.Types; 26with Grt.Hooks; use Grt.Hooks; 27with Grt.Errors; use Grt.Errors; 28with Grt.Backtraces.Impl; 29 30package body Grt.Backtraces is 31 -- If true, disp address in backtraces. 32 Flag_Address : Boolean := False; 33 34 subtype Address_Image_String is String (1 .. Integer_Address'Size / 4); 35 36 Hex : constant array (Natural range 0 .. 15) of Character := 37 "0123456789abcdef"; 38 39 function Address_Image (Addr : Integer_Address) 40 return Address_Image_String 41 is 42 V : Integer_Address; 43 Res : Address_Image_String; 44 begin 45 V := Addr; 46 for I in reverse Res'Range loop 47 Res (I) := Hex (Natural (V mod 16)); 48 V := V / 16; 49 end loop; 50 return Res; 51 end Address_Image; 52 53 function File_Basename (Name : Ghdl_C_String) return Ghdl_C_String 54 is 55 Sep : Natural; 56 begin 57 Sep := 0; 58 for I in Name'Range loop 59 case Name (I) is 60 when '\' | '/' => 61 Sep := I + 1; 62 when NUL => 63 exit; 64 when others => 65 null; 66 end case; 67 end loop; 68 if Sep /= 0 and then Name (Sep) /= NUL then 69 return To_Ghdl_C_String (Name (Sep)'Address); 70 else 71 return Name; 72 end if; 73 end File_Basename; 74 75 function Is_Eq (Str : Ghdl_C_String; Ref : String) return Boolean is 76 begin 77 for I in Ref'Range loop 78 if Str (Str'First + I - Ref'First) /= Ref (I) then 79 return False; 80 end if; 81 end loop; 82 return Str (Str'First + Ref'Length) = NUL; 83 end Is_Eq; 84 85 type Op_Assoc_Type is record 86 Enc : String (1 .. 2); 87 Op : String (1 .. 4); 88 end record; 89 90 type Op_Array_Type is array (Positive range <>) of Op_Assoc_Type; 91 Op_Assoc : constant Op_Array_Type := 92 (("Eq", "= "), 93 ("Ne", "/= "), 94 ("Lt", "< "), 95 ("Le", "<= "), 96 ("Gt", "> "), 97 ("Ge", ">= "), 98 ("Pl", "+ "), 99 ("Mi", "- "), 100 ("Mu", "* "), 101 ("Di", "/ "), 102 ("Ex", "** "), 103 ("Cc", "& "), 104 ("Cd", "?? "), 105 ("Qe", "?= "), 106 ("Qi", "?/= "), 107 ("QL", "?< "), 108 ("Ql", "?<= "), 109 ("QG", "?> "), 110 ("Qg", "?>= ")); 111 112 procedure Demangle_Op_Err (C1, C2 : Character) is 113 begin 114 for I in Op_Assoc'Range loop 115 declare 116 A : Op_Assoc_Type renames Op_Assoc (I); 117 begin 118 if A.Enc (1) = C1 and A.Enc (2) = C2 then 119 Put_Err ('"'); 120 for J in A.Op'range loop 121 exit when A.Op (J) = ' '; 122 Put_Err (A.Op (J)); 123 end loop; 124 Put_Err ('"'); 125 return; 126 end if; 127 end; 128 end loop; 129 Put_Err ("OP"); 130 Put_Err (C1); 131 Put_Err (C2); 132 end Demangle_Op_Err; 133 134 procedure Demangle_Err (Name : Ghdl_C_String) 135 is 136 subtype Digit is Character range '0' .. '9'; 137 Last_Part : Natural; 138 Suffix : Ghdl_C_String; 139 Off : Natural; 140 C : Character; 141 Is_Arch : Boolean; 142 begin 143 if Name (1) = '_' then 144 -- Recognize elaboration routine. 145 if Is_Eq (Name, "__ghdl_ELABORATE") then 146 Put_Err ("Elaboration of design"); 147 return; 148 end if; 149 end if; 150 151 -- Find last suffix (as it indicates processes and elaborator). 152 Last_Part := 0; 153 for I in Name'Range loop 154 exit when Name (I) = NUL; 155 if Name (I) = '_' and then Name (I + 1) = '_' then 156 Last_Part := I; 157 end if; 158 end loop; 159 160 if Last_Part /= 0 then 161 Suffix := To_Ghdl_C_String (Name (Last_Part)'Address); 162 if Is_Eq (Suffix, "__ELAB") then 163 Put_Err ("elaboration of "); 164 elsif Is_Eq (Suffix, "__PROC") then 165 Put_Err ("process "); 166 else 167 Last_Part := 0; 168 end if; 169 end if; 170 Off := 1; 171 Is_Arch := False; 172 loop 173 exit when Off = Last_Part; 174 C := Name (Off); 175 Off := Off + 1; 176 exit when C = NUL; 177 if C = '_' and then Name (Off) = '_' then 178 if Name (Off + 1) = 'A' 179 and then Name (Off + 2) = 'R' 180 and then Name (Off + 3) = 'C' 181 and then Name (Off + 4) = 'H' 182 and then Name (Off + 5) = '_' 183 and then Name (Off + 6) = '_' 184 then 185 -- Recognize '__ARCH' and replaces 'x__ARCH__y' by 'x(y)'. 186 Off := Off + 7; 187 Put_Err ('('); 188 Is_Arch := True; 189 else 190 if Is_Arch then 191 Put_Err (')'); 192 Is_Arch := False; 193 end if; 194 -- Replaces '__' by '.'. 195 Put_Err ('.'); 196 Off := Off + 1; 197 end if; 198 elsif C = 'O' then 199 if Name (Off) = 'P' then 200 -- __OPxx is an operator. 201 Demangle_Op_Err (Name (Off + 1), Name (Off + 2)); 202 Off := Off + 3; 203 elsif Name (Off) in Digit then 204 -- overloading 205 loop 206 Off := Off + 1; 207 exit when Name (Off) not in Digit; 208 end loop; 209 end if; 210 else 211 Put_Err (C); 212 end if; 213 end loop; 214 if Is_Arch then 215 Put_Err (')'); 216 end if; 217 end Demangle_Err; 218 219 procedure Put_Err_Backtrace (Bt : Backtrace_Addrs) 220 is 221 use System; 222 223 Filename : Address; 224 Lineno : Natural; 225 Subprg : Address; 226 Unknown : Boolean; 227 begin 228 if Bt.Size = 0 229 or else Bt.Skip >= Bt.Size 230 then 231 -- No backtrace or no symbolizer. 232 return; 233 end if; 234 235 Unknown := False; 236 for I in Bt.Skip .. Bt.Size loop 237 Backtraces.Impl.Symbolizer (To_Address (Bt.Addrs (I)), 238 Filename, Lineno, Subprg); 239 if Subprg = Null_Address 240 and (Filename = Null_Address or Lineno = 0) 241 then 242 Unknown := True; 243 elsif Subprg /= Null_Address 244 and then To_Ghdl_C_String (Subprg) (1 .. 5) = "grt__" 245 then 246 -- In the runtime. Stop now. 247 exit; 248 else 249 if Unknown then 250 Put_Err (" from: [unknown caller]"); 251 Newline_Err; 252 Unknown := False; 253 end if; 254 Put_Err (" from:"); 255 if Flag_Address then 256 Put_Err (" 0x"); 257 Put_Err (Address_Image (Bt.Addrs (I))); 258 end if; 259 if Subprg /= Null_Address then 260 Put_Err (' '); 261 Demangle_Err (To_Ghdl_C_String (Subprg)); 262 end if; 263 if Filename /= Null_Address and Lineno /= 0 then 264 Put_Err (" at "); 265 Put_Err (File_Basename (To_Ghdl_C_String (Filename))); 266 Put_Err (":"); 267 Put_Err (Lineno); 268 end if; 269 Newline_Err; 270 end if; 271 end loop; 272 end Put_Err_Backtrace; 273 274 -- Return TRUE if OPT is an option for backtrace. 275 function Backtrace_Option (Opt : String) return Boolean 276 is 277 F : constant Natural := Opt'First; 278 begin 279 if Opt'Length < 11 or else Opt (F .. F + 10) /= "--backtrace" then 280 return False; 281 end if; 282 if Opt'Length = 16 and then Opt (F + 11 .. F + 15) = "-addr" then 283 Flag_Address := True; 284 return True; 285 end if; 286 return False; 287 end Backtrace_Option; 288 289 Backtrace_Hooks : aliased constant Hooks_Type := 290 (Desc => new String'("backtrace: print backtrace on errors"), 291 Option => Backtrace_Option'Access, 292 Help => null, 293 Init => null, 294 Start => null, 295 Finish => null); 296 297 procedure Register is 298 begin 299 Register_Hooks (Backtrace_Hooks'Access); 300 end Register; 301 302end Grt.Backtraces; 303