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