diff options
Diffstat (limited to 'src/grt')
| -rw-r--r-- | src/grt/config/grt_itf.h | 40 | ||||
| -rw-r--r-- | src/grt/config/jumps.c | 104 | ||||
| -rw-r--r-- | src/grt/config/win32.c | 17 | ||||
| -rw-r--r-- | src/grt/grt-backtraces.adb | 232 | ||||
| -rw-r--r-- | src/grt/grt-backtraces.ads | 34 | ||||
| -rw-r--r-- | src/grt/grt-errors.adb | 35 | ||||
| -rw-r--r-- | src/grt/grt-errors.ads | 43 | ||||
| -rw-r--r-- | src/grt/grt-lib.adb | 9 | ||||
| -rw-r--r-- | src/grt/grt-modules.adb | 2 |
9 files changed, 483 insertions, 33 deletions
diff --git a/src/grt/config/grt_itf.h b/src/grt/config/grt_itf.h new file mode 100644 index 000000000..1b17c3a8b --- /dev/null +++ b/src/grt/config/grt_itf.h @@ -0,0 +1,40 @@ +/* Declarations to interface with Ada code. + Copyright (C) 2015 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + +struct backtrace_addrs +{ + int size; + int skip; + void *addrs[32]; +}; + +void grt_save_backtrace (struct backtrace_addrs *bt, int skip); + +extern void grt_overflow_error (struct backtrace_addrs *bt); +extern void grt_null_access_error (struct backtrace_addrs *bt); + +void __ghdl_maybe_return_via_longjump (int val); +int __ghdl_run_through_longjump (int (*func)(void)); diff --git a/src/grt/config/jumps.c b/src/grt/config/jumps.c index a544f8372..00e17d37d 100644 --- a/src/grt/config/jumps.c +++ b/src/grt/config/jumps.c @@ -29,11 +29,17 @@ #include <signal.h> #include <fcntl.h> -#if defined (__linux__) && defined (__i386__) -/* On i386/Linux, the context must be inspected. */ +#if defined (__linux__) || defined (__APPLE__) +#define HAVE_BACKTRACE 1 #include <sys/ucontext.h> #endif +#ifdef HAVE_BACKTRACE +#include <execinfo.h> +#endif + +#include "grt_itf.h" + /* There is a simple setjmp/longjmp mechanism used to report failures. We have the choice between 3 mechanisms: * USE_BUITLIN_SJLJ: gcc builtin setjmp/longjmp, very fast but gcc specific. @@ -70,49 +76,89 @@ typedef jmp_buf JMP_BUF; static int run_env_en; static JMP_BUF run_env; -extern void grt_overflow_error (void); -extern void grt_null_access_error (void); - #ifdef __APPLE__ #define NEED_SIGFPE_HANDLER +#define NEED_SIGBUS_HANDLER #endif static struct sigaction prev_sigfpe_act; +#ifdef NEED_SIGFPE_HANDLER +static struct sigaction prev_sigsegv_act; +#endif +#ifdef NEED_SIGBUS_HANDLER +static struct sigaction prev_sigbus_act; +#endif + +static void +get_bt_from_ucontext (void *uctxt, struct backtrace_addrs *bt) +{ + void *pc = NULL; + int i; + +#ifdef HAVE_BACKTRACE + bt->size = backtrace (bt->addrs, sizeof (bt->addrs) / sizeof (void *)); + bt->skip = 0; +#else + bt->size = 0; + return; +#endif + +#if defined (__linux__) && defined (__x86_64__) + ucontext *u = (ucontext *)uctxt; + pc = (void *)u->uc_mcontext.gregs[REG_RIP]; +#endif +#if defined (__APPLE__) && defined (__i386__) + ucontext_t *u = (ucontext_t *)uctxt; + pc = (void *)u->uc_mcontext->__ss.__eip; + bt->skip = 3; /* This frame + sighandler + trampoline + marker - pc. */ + bt->addrs[3] = pc; +#endif +} + /* Handler for SIGFPE signal. It is also raised in case of overflow (i386 linux). */ -static void grt_overflow_handler (int signo, siginfo_t *info, void *ptr) +static void +grt_overflow_handler (int signo, siginfo_t *info, void *ptr) { - grt_overflow_error (); -} + struct backtrace_addrs bt; -static struct sigaction prev_sigsegv_act; + get_bt_from_ucontext (ptr, &bt); + grt_overflow_error (&bt); +} /* Posix handler for overflow. This is used only by mcode. */ -static void grt_sigsegv_handler (int signo, siginfo_t *info, void *ptr) +static void +grt_sigsegv_handler (int signo, siginfo_t *info, void *ptr) { -#if defined (__linux__) && defined (__i386__) - ucontext_t *uctxt = (ucontext_t *)ptr; + struct backtrace_addrs bt; - /* Linux generates a SIGSEGV (!) for an overflow exception. */ - if (uctxt->uc_mcontext.gregs[REG_TRAPNO] == 4) + get_bt_from_ucontext (ptr, &bt); + +#if defined (__linux__) && defined (__i386__) + if (signo == SIGSEGV) { - grt_overflow_error (); + ucontext_t *uctxt = (ucontext_t *)ptr; + + /* Linux generates a SIGSEGV (!) for an overflow exception. */ + if (uctxt->uc_mcontext.gregs[REG_TRAPNO] == 4) + grt_overflow_error (&bt); } #endif /* We loose. */ - grt_null_access_error (); + grt_null_access_error (&bt); } -static void grt_signal_setup (void) +static void +grt_signal_setup (void) { { struct sigaction sigsegv_act; sigsegv_act.sa_sigaction = &grt_sigsegv_handler; sigemptyset (&sigsegv_act.sa_mask); - sigsegv_act.sa_flags = SA_ONSTACK | SA_SIGINFO; + sigsegv_act.sa_flags = SA_SIGINFO; #ifdef SA_ONESHOT sigsegv_act.sa_flags |= SA_ONESHOT; #elif defined (SA_RESETHAND) @@ -122,6 +168,10 @@ static void grt_signal_setup (void) /* We don't care about the return status. If the handler is not installed, then some feature are lost. */ sigaction (SIGSEGV, &sigsegv_act, &prev_sigsegv_act); + +#ifdef NEED_SIGBUS_HANDLER + sigaction (SIGBUS, &sigsegv_act, &prev_sigbus_act); +#endif } #ifdef NEED_SIGFPE_HANDLER @@ -137,10 +187,15 @@ static void grt_signal_setup (void) #endif } -static void grt_signal_restore (void) +static void +grt_signal_restore (void) { sigaction (SIGSEGV, &prev_sigsegv_act, NULL); +#ifdef NEED_SIGBUS_HANDLER + sigaction (SIGBUS, &prev_sigbus_act, NULL); +#endif + #ifdef NEED_SIGFPE_HANDLER sigaction (SIGFPE, &prev_sigfpe_act, NULL); #endif @@ -167,3 +222,14 @@ __ghdl_run_through_longjump (int (*func)(void)) run_env_en = 0; return res; } + +void +grt_save_backtrace (struct backtrace_addrs *bt, int skip) +{ +#ifdef HAVE_BACKTRACE + bt->size = backtrace (bt->addrs, sizeof (bt->addrs) / sizeof (void *)); + bt->skip = skip + 1; +#else + bt->size = 0; +#endif +} diff --git a/src/grt/config/win32.c b/src/grt/config/win32.c index 869c7ca61..63d11a23e 100644 --- a/src/grt/config/win32.c +++ b/src/grt/config/win32.c @@ -30,13 +30,11 @@ #include <assert.h> #include <excpt.h> +#include "grt_itf.h" + static int run_env_en; static jmp_buf run_env; -extern void grt_overflow_error (void); -extern void grt_null_access_error (void); -void __ghdl_maybe_return_via_longjump (int val); - static EXCEPTION_DISPOSITION ghdl_SEH_handler (struct _EXCEPTION_RECORD* ExceptionRecord, void *EstablisherFrame, @@ -60,7 +58,8 @@ ghdl_SEH_handler (struct _EXCEPTION_RECORD* ExceptionRecord, switch (ExceptionRecord->ExceptionCode) { case EXCEPTION_ACCESS_VIOLATION: - grt_null_access_error (); + /* Pc is ExceptionRecord->ExceptionAddress. */ + grt_null_access_error (NULL); break; case EXCEPTION_FLT_DENORMAL_OPERAND: @@ -77,7 +76,7 @@ ghdl_SEH_handler (struct _EXCEPTION_RECORD* ExceptionRecord, break; case EXCEPTION_INT_OVERFLOW: - grt_overflow_error (); + grt_overflow_error (NULL); break; case EXCEPTION_STACK_OVERFLOW: @@ -132,6 +131,12 @@ __ghdl_run_through_longjump (int (*func)(void)) return res; } +void +grt_save_backtrace (struct backtrace_addrs *bt, int skip) +{ + bt->size = 0; +} + #include <math.h> double acosh (double x) diff --git a/src/grt/grt-backtraces.adb b/src/grt/grt-backtraces.adb new file mode 100644 index 000000000..8b779a7d8 --- /dev/null +++ b/src/grt/grt-backtraces.adb @@ -0,0 +1,232 @@ +-- GHDL Run Time (GRT) - Backtraces and symbolization. +-- Copyright (C) 2015 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with System; +with Grt.Types; use Grt.Types; +with Grt.Hooks; use Grt.Hooks; + +package body Grt.Backtraces is + -- If true, disp address in backtraces. + Flag_Address : Boolean := False; + + subtype Address_Image_String is String (1 .. Integer_Address'Size / 4); + + Hex : constant array (Natural range 0 .. 15) of Character := + "0123456789abcdef"; + + function Address_Image (Addr : Integer_Address) + return Address_Image_String + is + V : Integer_Address; + Res : Address_Image_String; + begin + V := Addr; + for I in reverse Res'Range loop + Res (I) := Hex (Natural (V mod 16)); + V := V / 16; + end loop; + return Res; + end Address_Image; + + function File_Basename (Name : Ghdl_C_String) return Ghdl_C_String + is + Sep : Natural; + begin + Sep := 0; + for I in Name'Range loop + case Name (I) is + when '\' | '/' => + Sep := I + 1; + when NUL => + exit; + when others => + null; + end case; + end loop; + if Sep /= 0 and then Name (Sep) /= NUL then + return To_Ghdl_C_String (Name (Sep)'Address); + else + return Name; + end if; + end File_Basename; + + function Is_Eq (Str : Ghdl_C_String; Ref : String) return Boolean is + begin + for I in Ref'Range loop + if Str (Str'First + I - Ref'First) /= Ref (I) then + return False; + end if; + end loop; + return Str (Str'First + Ref'Length) = NUL; + end Is_Eq; + + procedure Demangle_Err (Name : Ghdl_C_String) + is + Last_Part : Natural; + Suffix : Ghdl_C_String; + Off : Natural; + C : Character; + Is_Arch : Boolean; + begin + if Name (1) = '_' then + if Is_Eq (Name, "__ghdl_ELABORATE") then + Put_Err ("Elaboration of design"); + return; + end if; + end if; + + -- Find last suffix (as it indicates processes and elaborator). + Last_Part := 0; + for I in Name'Range loop + exit when Name (I) = NUL; + if Name (I) = '_' and then Name (I + 1) = '_' then + Last_Part := I; + end if; + end loop; + + if Last_Part /= 0 then + Suffix := To_Ghdl_C_String (Name (Last_Part)'Address); + if Is_Eq (Suffix, "__ELAB") then + Put_Err ("elaboration of "); + elsif Is_Eq (Suffix, "__PROC") then + Put_Err ("process "); + else + Last_Part := 0; + end if; + end if; + Off := 1; + Is_Arch := False; + loop + exit when Off = Last_Part; + C := Name (Off); + Off := Off + 1; + exit when C = NUL; + if C = '_' and then Name (Off) = '_' then + if Name (Off + 1) = 'A' + and then Name (Off + 2) = 'R' + and then Name (Off + 3) = 'C' + and then Name (Off + 4) = 'H' + and then Name (Off + 5) = '_' + and then Name (Off + 6) = '_' + then + Off := Off + 7; + Put_Err ('('); + Is_Arch := True; + else + if Is_Arch then + Put_Err (')'); + Is_Arch := False; + end if; + Put_Err ('.'); + Off := Off + 1; + end if; + else + Put_Err (C); + end if; + end loop; + if Is_Arch then + Put_Err (')'); + end if; + end Demangle_Err; + + procedure Put_Err_Backtrace (Bt : Backtrace_Addrs) + is + use System; + + Filename : Address; + Lineno : Natural; + Subprg : Address; + Unknown : Boolean; + begin + if Bt.Size = 0 + or else Bt.Skip >= Bt.Size + or else Symbolizer = null + then + -- No backtrace or no symbolizer. + return; + end if; + + Unknown := False; + for I in Bt.Skip .. Bt.Size loop + Symbolizer.all (To_Address (Bt.Addrs (I)), + Filename, Lineno, Subprg); + if Subprg = Null_Address + and (Filename = Null_Address or Lineno = 0) + then + Unknown := True; + else + if Unknown then + Put_Err (" from: [unknown caller]"); + Unknown := False; + end if; + Put_Err (" from:"); + if Flag_Address then + Put_Err (" 0x"); + Put_Err (Address_Image (Bt.Addrs (I))); + end if; + if Subprg /= Null_Address then + Put_Err (' '); + Demangle_Err (To_Ghdl_C_String (Subprg)); + end if; + if Filename /= Null_Address and Lineno /= 0 then + Put_Err (" at "); + Put_Err (File_Basename (To_Ghdl_C_String (Filename))); + Put_Err (":"); + Put_Err (Lineno); + end if; + Newline_Err; + end if; + end loop; + end Put_Err_Backtrace; + + -- Return TRUE if OPT is an option for backtrace. + function Backtrace_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + begin + if Opt'Length < 10 or else Opt (F .. F + 10) /= "--backtrace" then + return False; + end if; + if Opt'Length = 16 and then Opt (F + 11 .. F + 15) = "-addr" then + Flag_Address := True; + return True; + end if; + return False; + end Backtrace_Option; + + Backtrace_Hooks : aliased constant Hooks_Type := + (Desc => new String'("backtrace: print backtrace on errors"), + Option => Backtrace_Option'Access, + Help => null, + Init => null, + Start => null, + Finish => null); + + procedure Register is + begin + Register_Hooks (Backtrace_Hooks'Access); + end Register; + +end Grt.Backtraces; diff --git a/src/grt/grt-backtraces.ads b/src/grt/grt-backtraces.ads new file mode 100644 index 000000000..697b9dd95 --- /dev/null +++ b/src/grt/grt-backtraces.ads @@ -0,0 +1,34 @@ +-- GHDL Run Time (GRT) - Backtraces and symbolization. +-- Copyright (C) 2015 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with Grt.Errors; use Grt.Errors; + +package Grt.Backtraces is + pragma Preelaborate (Grt.Backtraces); + + procedure Put_Err_Backtrace (Bt : Backtrace_Addrs); + + procedure Register; +end Grt.Backtraces; diff --git a/src/grt/grt-errors.adb b/src/grt/grt-errors.adb index 62ee86e2e..56d1e6f81 100644 --- a/src/grt/grt-errors.adb +++ b/src/grt/grt-errors.adb @@ -26,6 +26,7 @@ with Grt.Stdio; use Grt.Stdio; with Grt.Astdio; use Grt.Astdio; with Grt.Options; use Grt.Options; with Grt.Hooks; use Grt.Hooks; +with Grt.Backtraces; package body Grt.Errors is -- Called in case of premature exit. @@ -76,6 +77,11 @@ package body Grt.Errors is Put (stderr, Str); end Put_Err; + procedure Put_Err (C : Character) is + begin + Put (stderr, C); + end Put_Err; + procedure Put_Err (Str : Ghdl_C_String) is begin Put (stderr, Str); @@ -254,13 +260,34 @@ package body Grt.Errors is Fatal_Error; end Internal_Error; - procedure Grt_Overflow_Error is + procedure Error_E_Call_Stack (Bt : Backtrace_Addrs) is + begin + Newline_Err; + + Grt.Backtraces.Put_Err_Backtrace (Bt); + + Cont := False; + Fatal_Error; + end Error_E_Call_Stack; + + procedure Error_E_Call_Stack (Bt : Backtrace_Addrs_Acc) is + begin + if Bt /= null then + Error_E_Call_Stack (Bt.all); + else + Error_E; + end if; + end Error_E_Call_Stack; + + procedure Grt_Overflow_Error (Bt : Backtrace_Addrs_Acc) is begin - Error ("overflow detected"); + Error_C ("overflow detected"); + Error_E_Call_Stack (Bt); end Grt_Overflow_Error; - procedure Grt_Null_Access_Error is + procedure Grt_Null_Access_Error (Bt : Backtrace_Addrs_Acc) is begin - Error ("NULL access dereferenced"); + Error_C ("NULL access dereferenced"); + Error_E_Call_Stack (Bt); end Grt_Null_Access_Error; end Grt.Errors; diff --git a/src/grt/grt-errors.ads b/src/grt/grt-errors.ads index bb7aab9a4..cd7c3dcf5 100644 --- a/src/grt/grt-errors.ads +++ b/src/grt/grt-errors.ads @@ -22,6 +22,7 @@ -- covered by the GNU General Public License. This exception does not -- however invalidate any other reasons why the executable file might be -- covered by the GNU Public License. +with System; with Grt.Types; use Grt.Types; with Grt.Hooks; @@ -62,12 +63,44 @@ package Grt.Errors is -- Display a message which is not an error. procedure Info (Str : String); + -- Backtrace used to report call stack in case of error. + -- Note: for simplicity we assume that a PC is enough to display the + -- corresponding file name, line number and routine name. Might not be + -- true on some platforms. + -- There is a C version of this record in grt_itf.h + type Integer_Address_Array is array (Natural range <>) of Integer_Address; + type Backtrace_Addrs is record + Size : Natural; + Skip : Natural; + Addrs : Integer_Address_Array (0 .. 31); + end record; + pragma Convention (C, Backtrace_Addrs); + + type Backtrace_Addrs_Acc is access Backtrace_Addrs; + + type Symbolizer_Acc is access procedure (Pc : System.Address; + Filename : out System.Address; + Lineno : out Natural; + Subprg : out System.Address); + + Symbolizer : Symbolizer_Acc := null; + + procedure Save_Backtrace (Bt : out Backtrace_Addrs; Skip : Natural); + pragma Import (C, Save_Backtrace, "grt_save_backtrace"); + + -- Finish error message with a call stack. + procedure Error_E_Call_Stack (Bt : Backtrace_Addrs); + pragma No_Return (Error_E_Call_Stack); + + procedure Error_E_Call_Stack (Bt : Backtrace_Addrs_Acc); + pragma No_Return (Error_E_Call_Stack); + -- Display an error message for an overflow. - procedure Grt_Overflow_Error; + procedure Grt_Overflow_Error (Bt : Backtrace_Addrs_Acc); pragma No_Return (Grt_Overflow_Error); -- Display an error message for a NULL access dereference. - procedure Grt_Null_Access_Error; + procedure Grt_Null_Access_Error (Bt : Backtrace_Addrs_Acc); pragma No_Return (Grt_Null_Access_Error); -- Called at end of error message. Central point for failures. @@ -97,6 +130,12 @@ package Grt.Errors is -- If true, an error is expected and the exit status is inverted. Expect_Failure : Boolean := False; + -- Internal subprograms, to be called only by the symbolizer. + procedure Put_Err (C : Character); + procedure Put_Err (Str : String); + procedure Put_Err (Str : Ghdl_C_String); + procedure Put_Err (N : Integer); + procedure Newline_Err; private pragma Export (C, Grt_Overflow_Error, "grt_overflow_error"); pragma Export (C, Grt_Null_Access_Error, "grt_null_access_error"); diff --git a/src/grt/grt-lib.adb b/src/grt/grt-lib.adb index d2b095c67..95a4a0948 100644 --- a/src/grt/grt-lib.adb +++ b/src/grt/grt-lib.adb @@ -46,6 +46,7 @@ package body Grt.Lib is Loc : Ghdl_Location_Ptr) is Level : constant Integer := Severity mod 256; + Bt : Backtrace_Addrs; begin Report_H; Report_C (Loc.Filename); @@ -77,8 +78,10 @@ package body Grt.Lib is Report_E (Default_Str); end if; if Level >= Grt.Options.Severity_Level then + Save_Backtrace (Bt, 2); Error_C (Msg); - Error_E (" failed"); + Error_C (" failed"); + Error_E_Call_Stack (Bt); end if; end Do_Report; @@ -161,12 +164,14 @@ package body Grt.Lib is procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String; Line: Ghdl_I32) is + Bt : Backtrace_Addrs; begin + Save_Backtrace (Bt, 1); Error_C ("bound check failure at "); Error_C (Filename); Error_C (":"); Error_C (Integer (Line)); - Error_E (""); + Error_E_Call_Stack (Bt); end Ghdl_Bound_Check_Failed_L1; function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32) diff --git a/src/grt/grt-modules.adb b/src/grt/grt-modules.adb index 3fc6c4ec2..0feb46cb1 100644 --- a/src/grt/grt-modules.adb +++ b/src/grt/grt-modules.adb @@ -32,6 +32,7 @@ with Grt.Waves; with Grt.Vital_Annotate; with Grt.Disp_Tree; with Grt.Disp_Rti; +with Grt.Backtraces; package body Grt.Modules is procedure Register_Modules is @@ -45,5 +46,6 @@ package body Grt.Modules is Grt.Vpi.Register; Grt.Vital_Annotate.Register; Grt.Disp_Rti.Register; + Grt.Backtraces.Register; end Register_Modules; end Grt.Modules; |