diff options
Diffstat (limited to 'src')
24 files changed, 1400 insertions, 147 deletions
diff --git a/src/ghdldrv/ghdlrun.adb b/src/ghdldrv/ghdlrun.adb index 51cc6b057..eac070278 100644 --- a/src/ghdldrv/ghdlrun.adb +++ b/src/ghdldrv/ghdlrun.adb @@ -591,6 +591,8 @@ package body Ghdlrun is Grtlink.Flag_String := Flags.Flag_String; + Grt.Errors.Symbolizer := Ortho_Jit.Symbolize'Access; + Elaborate_Proc := Conv (Ortho_Jit.Get_Address (Trans_Decls.Ghdl_Elaborate)); 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; diff --git a/src/ortho/mcode/binary_file-format.ads b/src/ortho/mcode/binary_file-format.ads new file mode 100644 index 000000000..57a65b70d --- /dev/null +++ b/src/ortho/mcode/binary_file-format.ads @@ -0,0 +1,20 @@ +-- Binary file writer. +-- 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. +with Binary_File.Elf; + +package Binary_File.Format renames Binary_File.Elf; diff --git a/src/ortho/mcode/binary_file-memory.adb b/src/ortho/mcode/binary_file-memory.adb index a37af9cb7..9797cd6b9 100644 --- a/src/ortho/mcode/binary_file-memory.adb +++ b/src/ortho/mcode/binary_file-memory.adb @@ -16,17 +16,12 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Ada.Text_IO; use Ada.Text_IO; -with Ada.Unchecked_Conversion; package body Binary_File.Memory is -- Absolute section. Sect_Abs : Section_Acc; - function To_Pc_Type is new Ada.Unchecked_Conversion - (Source => System.Address, Target => Pc_Type); - - procedure Set_Symbol_Address (Sym : Symbol; Addr : System.Address) - is + procedure Set_Symbol_Address (Sym : Symbol; Addr : System.Address) is begin Set_Symbol_Value (Sym, To_Pc_Type (Addr)); Set_Scope (Sym, Sym_Global); @@ -48,20 +43,21 @@ package body Binary_File.Memory is -- Relocate section in memory. Sect := Section_Chain; while Sect /= null loop + -- Allocate memory if needed (eg: .bss) if Sect.Data = null then if Sect.Pc > 0 then Resize (Sect, Sect.Pc); Sect.Data (0 .. Sect.Pc - 1) := (others => 0); - else - null; - --Sect.Data := new Byte_Array (1 .. 0); end if; end if; - if Sect.Data_Max > 0 + + -- Set virtual address. + if Sect.Pc > 0 and (Sect /= Sect_Abs and Sect.Flags /= Section_Debug) then Sect.Vaddr := To_Pc_Type (Sect.Data (0)'Address); end if; + Sect := Sect.Next; end loop; @@ -98,4 +94,14 @@ package body Binary_File.Memory is Sect := Sect.Next; end loop; end Write_Memory_Relocate; + + function Get_Section_Base (Sect : Section_Acc) return System.Address is + begin + return Sect.Data (0)'Address; + end Get_Section_Base; + + function Get_Section_Size (Sect : Section_Acc) return Pc_Type is + begin + return Sect.Pc; + end Get_Section_Size; end Binary_File.Memory; diff --git a/src/ortho/mcode/binary_file-memory.ads b/src/ortho/mcode/binary_file-memory.ads index a205da527..cc2b7e39b 100644 --- a/src/ortho/mcode/binary_file-memory.ads +++ b/src/ortho/mcode/binary_file-memory.ads @@ -15,6 +15,8 @@ -- 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. +with Ada.Unchecked_Conversion; + package Binary_File.Memory is -- Must be called before set_symbol_address. @@ -22,4 +24,13 @@ package Binary_File.Memory is procedure Set_Symbol_Address (Sym : Symbol; Addr : System.Address); procedure Write_Memory_Relocate (Error : out Boolean); + + function Get_Section_Base (Sect : Section_Acc) return System.Address; + function Get_Section_Size (Sect : Section_Acc) return Pc_Type; + + function To_Pc_Type is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Pc_Type); + function To_Address is new Ada.Unchecked_Conversion + (Source => Pc_Type, Target => System.Address); + end Binary_File.Memory; diff --git a/src/ortho/mcode/dwarf.ads b/src/ortho/mcode/dwarf.ads index 40ee94f10..8a3058c0e 100644 --- a/src/ortho/mcode/dwarf.ads +++ b/src/ortho/mcode/dwarf.ads @@ -396,6 +396,7 @@ package Dwarf is DW_LNS_Set_Isa : constant Unsigned_8 := 12; -- Line number extended opcode. + -- Encoding is 0:Len:LNE_OP:data DW_LNE_End_Sequence : constant Unsigned_8 := 1; DW_LNE_Set_Address : constant Unsigned_8 := 2; DW_LNE_Define_File : constant Unsigned_8 := 3; @@ -442,5 +443,3 @@ package Dwarf is DW_EH_PE_Datarel : constant Unsigned_8 := 16#30#; DW_EH_PE_Format_Mask : constant Unsigned_8 := 16#0f#; end Dwarf; - - diff --git a/src/ortho/mcode/ortho_code-dwarf.adb b/src/ortho/mcode/ortho_code-dwarf.adb index 309c82dea..521ab85f3 100644 --- a/src/ortho/mcode/ortho_code-dwarf.adb +++ b/src/ortho/mcode/ortho_code-dwarf.adb @@ -18,13 +18,12 @@ with GNAT.Directory_Operations; with Tables; with Interfaces; use Interfaces; -with Binary_File; use Binary_File; with Dwarf; use Dwarf; with Ada.Text_IO; +with Ortho_Code.Flags; use Ortho_Code.Flags; with Ortho_Code.Decls; with Ortho_Code.Types; with Ortho_Code.Consts; -with Ortho_Code.Flags; with Ortho_Ident; with Ortho_Code.Binary; @@ -52,21 +51,8 @@ package body Ortho_Code.Dwarf is Info_Sym : Symbol; Line_Sym : Symbol; - Line_Sect : Section_Acc; - Abbrev_Sect : Section_Acc; - Info_Sect : Section_Acc; - Aranges_Sect : Section_Acc; - Abbrev_Last : Unsigned_32; --- procedure Gen_String (Str : String) --- is --- begin --- for I in Str'Range loop --- Gen_B8 (Character'Pos (Str (I))); --- end loop; --- end Gen_String; - procedure Gen_String_Nul (Str : String) is begin @@ -118,12 +104,6 @@ package body Ortho_Code.Dwarf is end loop; end Gen_Uleb128; --- procedure New_Debug_Line_Decl (Line : Int32) --- is --- begin --- Line_Last := Line; --- end New_Debug_Line_Decl; - procedure Set_Line_Stmt (Line : Int32) is Pc : Pc_Type; @@ -154,6 +134,7 @@ package body Ortho_Code.Dwarf is Gen_Uleb128 (Unsigned_32 (Cur_File)); Last_File := Cur_File; elsif Cur_File = 0 then + -- No file yet. return; end if; @@ -173,7 +154,6 @@ package body Ortho_Code.Dwarf is + Byte (D_Pc) * Line_Range + Byte (D_Ln - Line_Base)); - --Set_Current_Section (Text_Sect); Line_Pc := Pc; Line_Last := Line; end Set_Line_Stmt; @@ -269,13 +249,11 @@ package body Ortho_Code.Dwarf is Gen_Uleb128 (Form); end Gen_Abbrev_Tuple; - procedure Init - is + procedure Init is begin -- Generate type names. Flags.Flag_Type_Name := True; - Orig_Sym := Create_Local_Symbol; Set_Symbol_Pc (Orig_Sym, False); End_Sym := Create_Local_Symbol; @@ -533,10 +511,9 @@ package body Ortho_Code.Dwarf is is Off : Pc_Type; begin + pragma Assert (Flag_Debug >= Debug_Dwarf); Off := TOnodes.Table (Atype); - if Off = Null_Pc then - raise Program_Error; - end if; + pragma Assert (Off /= Null_Pc); Gen_32 (Unsigned_32 (Off)); end Emit_Type_Ref; @@ -979,6 +956,10 @@ package body Ortho_Code.Dwarf is Kind : OT_Kind; Decl : O_Dnode; begin + if Flag_Debug < Debug_Dwarf then + return; + end if; + -- If already emitted, then return. if Atype <= TOnodes.Last and then TOnodes.Table (Atype) /= Null_Pc @@ -1160,21 +1141,23 @@ package body Ortho_Code.Dwarf is Sdecl : O_Dnode; Sibling_Pc : Pc_Type; begin - if Abbrev_Block = 0 then - Generate_Abbrev (Abbrev_Block); + if Flag_Debug >= Debug_Dwarf then + if Abbrev_Block = 0 then + Generate_Abbrev (Abbrev_Block); - Gen_Abbrev_Header (DW_TAG_Lexical_Block, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); - Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (0, 0); - end if; + Gen_Abbrev_Header (DW_TAG_Lexical_Block, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); + Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); + Gen_Abbrev_Tuple (0, 0); + end if; - Gen_Info_Header (Abbrev_Block); - Sibling_Pc := Gen_Info_Sibling; + Gen_Info_Header (Abbrev_Block); + Sibling_Pc := Gen_Info_Sibling; - Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info1 (Decl))); - Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info2 (Decl))); + Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info1 (Decl))); + Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info2 (Decl))); + end if; -- Emit decls for children. Last := Get_Block_Last (Decl); @@ -1184,11 +1167,13 @@ package body Ortho_Code.Dwarf is Sdecl := Get_Decl_Chain (Sdecl); end loop; - -- End of children. - Set_Current_Section (Info_Sect); - Gen_Uleb128 (0); + if Flag_Debug >= Debug_Dwarf then + -- End of children. + Set_Current_Section (Info_Sect); + Gen_Uleb128 (0); - Patch_Info_Sibling (Sibling_Pc); + Patch_Info_Sibling (Sibling_Pc); + end if; end Emit_Block_Decl; Abbrev_Function : Unsigned_32 := 0; @@ -1198,15 +1183,12 @@ package body Ortho_Code.Dwarf is procedure Emit_Subprg_Body (Bod : O_Dnode) is use Ortho_Code.Decls; - Kind : OD_Kind; - Decl : O_Dnode; + Decl : constant O_Dnode := Get_Body_Decl (Bod); + Kind : constant OD_Kind := Get_Decl_Kind (Decl); Idecl : O_Dnode; Prev_Subprg_Sym : Symbol; Sibling_Pc : Pc_Type; begin - Decl := Get_Body_Decl (Bod); - Kind := Get_Decl_Kind (Decl); - -- Emit interfaces type. Idecl := Get_Subprg_Interfaces (Decl); while Idecl /= O_Dnode_Null loop @@ -1220,13 +1202,15 @@ package body Ortho_Code.Dwarf is Generate_Abbrev (Abbrev_Function); Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); - - Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); + + if Flag_Debug >= Debug_Dwarf then + Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); + end if; --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1); Gen_Abbrev_Tuple (0, 0); end if; @@ -1236,37 +1220,48 @@ package body Ortho_Code.Dwarf is Generate_Abbrev (Abbrev_Procedure); Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes); - Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); - Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); + if Flag_Debug >= Debug_Dwarf then + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); + end if; --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1); Gen_Abbrev_Tuple (0, 0); end if; Gen_Info_Header (Abbrev_Procedure); end if; - Sibling_Pc := Gen_Info_Sibling; - - if Kind = OD_Function then - Emit_Decl_Type (Decl); - end if; - + -- Name. Emit_Decl_Ident (Decl); + + -- Low, High. Prev_Subprg_Sym := Subprg_Sym; Subprg_Sym := Binary.Get_Decl_Symbol (Decl); Gen_Ua_32 (Subprg_Sym, 0); Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Body_Info (Bod))); - -- Frame base. - Gen_B8 (1); - Gen_B8 (DW_OP_Reg5); + if Flag_Debug >= Debug_Dwarf then + -- Type. + if Kind = OD_Function then + Emit_Decl_Type (Decl); + end if; + + -- Sibling. + Sibling_Pc := Gen_Info_Sibling; + + -- Frame base. + Gen_B8 (1); + Gen_B8 (DW_OP_Reg5); + end if; -- Interfaces. Idecl := Get_Subprg_Interfaces (Decl); - if Idecl /= O_Dnode_Null then + if Idecl /= O_Dnode_Null + and then Flag_Debug >= Debug_Dwarf + then if Abbrev_Interface = 0 then Generate_Abbrev (Abbrev_Interface); @@ -1295,7 +1290,9 @@ package body Ortho_Code.Dwarf is -- End of children. Gen_Uleb128 (0); - Patch_Info_Sibling (Sibling_Pc); + if Flag_Debug >= Debug_Dwarf then + Patch_Info_Sibling (Sibling_Pc); + end if; Subprg_Sym := Prev_Subprg_Sym; end Emit_Subprg_Body; @@ -1305,26 +1302,32 @@ package body Ortho_Code.Dwarf is use Ada.Text_IO; use Ortho_Code.Decls; begin - case Get_Decl_Kind (Decl) is - when OD_Type => - Emit_Type_Decl (Decl); - when OD_Local - | OD_Var => - Emit_Variable (Decl); - when OD_Const => - Emit_Const (Decl); - when OD_Function - | OD_Procedure - | OD_Interface => - null; - when OD_Body => + if Flag_Debug = Debug_Dwarf then + case Get_Decl_Kind (Decl) is + when OD_Type => + Emit_Type_Decl (Decl); + when OD_Local + | OD_Var => + Emit_Variable (Decl); + when OD_Const => + Emit_Const (Decl); + when OD_Function + | OD_Procedure + | OD_Interface => + null; + when OD_Body => + Emit_Subprg_Body (Decl); + when OD_Block => + Emit_Block_Decl (Decl); + when others => + Put_Line ("dwarf.emit_decl: emit " + & OD_Kind'Image (Get_Decl_Kind (Decl))); + end case; + elsif Flag_Debug = Debug_Line then + if Get_Decl_Kind (Decl) = OD_Body then Emit_Subprg_Body (Decl); - when OD_Block => - Emit_Block_Decl (Decl); - when others => - Put_Line ("dwarf.emit_decl: emit " - & OD_Kind'Image (Get_Decl_Kind (Decl))); - end case; + end if; + end if; end Emit_Decl; procedure Emit_Subprg (Bod : O_Dnode) is @@ -1347,4 +1350,3 @@ package body Ortho_Code.Dwarf is end Release; end Ortho_Code.Dwarf; - diff --git a/src/ortho/mcode/ortho_code-dwarf.ads b/src/ortho/mcode/ortho_code-dwarf.ads index c120bcfe1..095a80da6 100644 --- a/src/ortho/mcode/ortho_code-dwarf.ads +++ b/src/ortho/mcode/ortho_code-dwarf.ads @@ -15,6 +15,8 @@ -- 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. +with Binary_File; use Binary_File; + package Ortho_Code.Dwarf is procedure Init; procedure Finish; @@ -33,6 +35,12 @@ package Ortho_Code.Dwarf is procedure Mark (M : out Mark_Type); procedure Release (M : Mark_Type); + -- Sections created by dwarf. + Line_Sect : Section_Acc; + Abbrev_Sect : Section_Acc; + Info_Sect : Section_Acc; + Aranges_Sect : Section_Acc; + private type Mark_Type is record Last_Decl : O_Dnode; diff --git a/src/ortho/mcode/ortho_code-flags.ads b/src/ortho/mcode/ortho_code-flags.ads index 214cc743b..30bded94e 100644 --- a/src/ortho/mcode/ortho_code-flags.ads +++ b/src/ortho/mcode/ortho_code-flags.ads @@ -16,10 +16,10 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. package Ortho_Code.Flags is - type Debug_Type is (Debug_None, Debug_Dwarf); + type Debug_Type is (Debug_None, Debug_Line, Debug_Dwarf); -- Debugging information generated. - Flag_Debug : Debug_Type := Debug_None; + Flag_Debug : Debug_Type := Debug_Line; -- If set, generate a map from type to type declaration. -- Set with --be-debug=t diff --git a/src/ortho/mcode/ortho_code-x86-abi.adb b/src/ortho/mcode/ortho_code-x86-abi.adb index 2be10fe0e..0a4433941 100644 --- a/src/ortho/mcode/ortho_code-x86-abi.adb +++ b/src/ortho/mcode/ortho_code-x86-abi.adb @@ -115,7 +115,7 @@ package body Ortho_Code.X86.Abi is Emits.Emit_Subprg (Subprg); if Get_Decl_Depth (Subprg.D_Decl) = O_Toplevel - and then Flag_Debug = Debug_Dwarf + and then Flag_Debug /= Debug_None then Dwarf.Emit_Decls_Until (Subprg.D_Body); if not Debug.Flag_Debug_Keep then @@ -133,7 +133,8 @@ package body Ortho_Code.X86.Abi is Cur_Subprg := Subprg; if Get_Decl_Depth (Subprg.D_Decl) = O_Toplevel then - if Flag_Debug = Debug_Dwarf then + -- Only for top-level subprograms. + if Flag_Debug /= Debug_None then Dwarf.Emit_Subprg (Subprg.D_Body); end if; @@ -142,7 +143,7 @@ package body Ortho_Code.X86.Abi is Release (Decls_Mark); Consts.Release (Consts_Mark); Release (Types_Mark); - if Flag_Debug = Debug_Dwarf then + if Flag_Debug /= Debug_None then Dwarf.Release (Dwarf_Mark); end if; end if; @@ -607,7 +608,7 @@ package body Ortho_Code.X86.Abi is is use Ortho_Code.Flags; begin - if Flag_Debug = Debug_Dwarf then + if Flag_Debug /= Debug_None then Dwarf.Set_Filename ("", Filename); end if; end New_Debug_Filename_Decl; diff --git a/src/ortho/mcode/ortho_code-x86-emits.adb b/src/ortho/mcode/ortho_code-x86-emits.adb index 412080150..c4cfee930 100644 --- a/src/ortho/mcode/ortho_code-x86-emits.adb +++ b/src/ortho/mcode/ortho_code-x86-emits.adb @@ -2356,7 +2356,7 @@ package body Ortho_Code.X86.Emits is null; when OE_Line => - if Flag_Debug = Debug_Dwarf then + if Flag_Debug /= Debug_None then Dwarf.Set_Line_Stmt (Get_Expr_Line_Number (Stmt)); Set_Current_Section (Sect_Text); end if; @@ -2516,7 +2516,7 @@ package body Ortho_Code.X86.Emits is Gen_1 (Opc_Leave); Gen_1 (Opc_Ret); - if Flag_Debug = Debug_Dwarf then + if Flag_Debug /= Debug_None then Set_Body_Info (Subprg.D_Body, Int32 (Get_Current_Pc - Subprg_Pc)); end if; end Emit_Epilogue; @@ -2704,7 +2704,7 @@ package body Ortho_Code.X86.Emits is Debug_Hex := True; end if; - if Flag_Debug = Debug_Dwarf then + if Flag_Debug /= Debug_None then Dwarf.Init; Set_Current_Section (Sect_Text); end if; @@ -2714,7 +2714,7 @@ package body Ortho_Code.X86.Emits is is use Ortho_Code.Flags; begin - if Flag_Debug = Debug_Dwarf then + if Flag_Debug /= Debug_None then Set_Current_Section (Sect_Text); Dwarf.Finish; end if; diff --git a/src/ortho/mcode/ortho_code_main.adb b/src/ortho/mcode/ortho_code_main.adb index c515f581c..b3a2e1988 100644 --- a/src/ortho/mcode/ortho_code_main.adb +++ b/src/ortho/mcode/ortho_code_main.adb @@ -83,6 +83,9 @@ begin elsif Arg = "-g" then Flag_Debug := Debug_Dwarf; I := I + 1; + elsif Arg = "-g0" then + Flag_Debug := Debug_None; + I := I + 1; elsif Arg = "-p" or Arg = "-pg" then Flag_Profile := True; I := I + 1; @@ -194,5 +197,3 @@ exception Set_Exit_Status (2); raise; end Ortho_Code_Main; - - diff --git a/src/ortho/mcode/ortho_jit.adb b/src/ortho/mcode/ortho_jit.adb index 907aea0b6..f01c8fafa 100644 --- a/src/ortho/mcode/ortho_jit.adb +++ b/src/ortho/mcode/ortho_jit.adb @@ -1,5 +1,5 @@ -- Ortho JIT implementation for mcode. --- Copyright (C) 2009 Tristan Gingold +-- Copyright (C) 2009 - 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 @@ -16,6 +16,8 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. +with System.Storage_Elements; use System.Storage_Elements; + with GNAT.OS_Lib; use GNAT.OS_Lib; with Ada.Text_IO; @@ -26,7 +28,9 @@ with Ortho_Mcode.Jit; with Ortho_Code.Flags; use Ortho_Code.Flags; with Ortho_Code.Debug; with Ortho_Code.Abi; -with Binary_File.Elf; +with Ortho_Code.Dwarf; +with Binary_File.Format; +with Symbolizer; package body Ortho_Jit is Snap_Filename : GNAT.OS_Lib.String_Access := null; @@ -76,7 +80,7 @@ package body Ortho_Jit is Status := False; return; else - Binary_File.Elf.Write (Fd); + Binary_File.Format.Write (Fd); Close (Fd); end if; end; @@ -98,6 +102,9 @@ package body Ortho_Jit is if Opt = "-g" then Flag_Debug := Debug_Dwarf; return True; + elsif Opt = "-g0" then + Flag_Debug := Debug_None; + return True; elsif Opt'Length > 5 and then Opt (1 .. 5) = "--be-" then Ortho_Code.Debug.Set_Be_Flag (Opt); return True; @@ -122,4 +129,43 @@ package body Ortho_Jit is return "mcode"; end Get_Jit_Name; + procedure Symbolize (Pc : Address; + Filename : out Address; + Lineno : out Natural; + Subprg : out Address) + is + use Binary_File.Memory; + use Symbolizer; + + function Get_Section_Content (Sect : Section_Acc) return Section_Content + is + Addr : Address; + Size : Pc_Type; + begin + if Sect = null then + return (Null_Address, 0); + else + Addr := Get_Section_Base (Sect); + Size := Get_Section_Size (Sect); + return (Addr, Storage_Offset (Size)); + end if; + end Get_Section_Content; + + Sections : Dwarf_Sections; + Res : Symbolize_Result; + begin + Sections.Debug_Line := + Get_Section_Content (Ortho_Code.Dwarf.Line_Sect); + Sections.Debug_Info := + Get_Section_Content (Ortho_Code.Dwarf.Info_Sect); + Sections.Debug_Abbrev := + Get_Section_Content (Ortho_Code.Dwarf.Abbrev_Sect); + + Symbolize_Address (Pc, Sections, Res); + + Filename := Res.Filename; + Lineno := Res.Line; + Subprg := Res.Subprg_Name; + end Symbolize; + end Ortho_Jit; diff --git a/src/ortho/mcode/symbolizer.adb b/src/ortho/mcode/symbolizer.adb new file mode 100644 index 000000000..79e7de24e --- /dev/null +++ b/src/ortho/mcode/symbolizer.adb @@ -0,0 +1,655 @@ +-- Dwarf symbolizer. +-- 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. + +with Ada.Unchecked_Conversion; +with Interfaces; use Interfaces; +with Dwarf; use Dwarf; + +package body Symbolizer is + type Abbrev_Array is array (Unsigned_32 range <>) of Address; + type Abbrev_Array_Acc is access Abbrev_Array; + + -- Data for decoding abbrevs. + -- Abbrevs are referenced by its number, but it is not possible to directly + -- reference an abbrev from its number. A map is required. + -- The main purpose of these data is to build the map. + type Abbrev_Data is record + -- Static map. Mcode doesn't generate a lot of abbrev. + Sarray : Abbrev_Array (1 .. 64); + -- First non-decoded abbrev. + Next_Num : Unsigned_32; + -- Address (in .debug_abbrev section) of the next abbrev to be decoded. + Next_Addr : Address; + -- Address of the first byte after the abbrev section. Used to not read + -- past the section. + Last_Addr : Address; + -- If there are too many abbrevs, use a resizable array instead of the + -- static one. + Map : Abbrev_Array_Acc; + end record; + + function Read_Byte (Addr : Address) return Unsigned_8 + is + type Unsigned_8_Acc is access all Unsigned_8; + function To_Unsigned_8_Acc is new Ada.Unchecked_Conversion + (Address, Unsigned_8_Acc); + begin + return To_Unsigned_8_Acc (Addr).all; + end Read_Byte; + + procedure Read_Word4 (Addr : in out Address; + Res : out Unsigned_32) + is + B0, B1, B2, B3 : Unsigned_8; + begin + B0 := Read_Byte (Addr + 0); + B1 := Read_Byte (Addr + 1); + B2 := Read_Byte (Addr + 2); + B3 := Read_Byte (Addr + 3); + -- FIXME: we assume little-endian + Res := Shift_Left (Unsigned_32 (B3), 24) + or Shift_Left (Unsigned_32 (B2), 16) + or Shift_Left (Unsigned_32 (B1), 8) + or Shift_Left (Unsigned_32 (B0), 0); + Addr := Addr + 4; + end Read_Word4; + + procedure Read_Word2 (Addr : in out Address; + Res : out Unsigned_16) + is + B0, B1 : Unsigned_8; + begin + B0 := Read_Byte (Addr + 0); + B1 := Read_Byte (Addr + 1); + -- FIXME: we assume little-endian + Res := Shift_Left (Unsigned_16 (B1), 8) + or Shift_Left (Unsigned_16 (B0), 0); + Addr := Addr + 2; + end Read_Word2; + + procedure Read_Byte (Addr : in out Address; + Res : out Unsigned_8) + is + begin + Res := Read_Byte (Addr); + Addr := Addr + 1; + end Read_Byte; + + procedure Read_ULEB128 (Addr : in out Address; + Res : out Unsigned_32) + is + B : Unsigned_8; + Shift : Integer; + begin + Res := 0; + Shift := 0; + loop + B := Read_Byte (Addr); + Addr := Addr + 1; + Res := Res or Shift_Left (Unsigned_32 (B and 16#7f#), Shift); + exit when (B and 16#80#) = 0; + Shift := Shift + 7; + end loop; + end Read_ULEB128; + + procedure Read_SLEB128 (Addr : in out Address; + Res : out Unsigned_32) + is + B : Unsigned_8; + Shift : Integer; + begin + Res := 0; + Shift := 0; + loop + B := Read_Byte (Addr); + Addr := Addr + 1; + Res := Res or Shift_Left (Unsigned_32 (B and 16#7f#), Shift); + Shift := Shift + 7; + exit when (B and 16#80#) = 0; + end loop; + if Shift < 32 and (Res and Shift_Left (1, Shift - 1)) /= 0 then + Res := Res or Shift_Left (-1, Shift); + end if; + end Read_SLEB128; + + procedure Init_Abbrev (Abbrevs : in out Abbrev_Data; + Sections : Dwarf_Sections; + Off : Storage_Offset) + is + Old_Map : Abbrev_Array_Acc; + begin + Old_Map := Abbrevs.Map; + if Old_Map /= null then + Old_Map.all := (others => Null_Address); + end if; + + Abbrevs := (Sarray => (others => Null_Address), + Next_Num => 0, + Next_Addr => Sections.Debug_Abbrev.Vaddr + Off, + Last_Addr => (Sections.Debug_Abbrev.Vaddr + + Sections.Debug_Abbrev.Size), + Map => Old_Map); + end Init_Abbrev; + + procedure Find_Abbrev (Abbrevs : in out Abbrev_Data; + Num : Unsigned_32; + Res : out Address) + is + Code : Unsigned_32; + Addr : Address; + Tag, Name, Form : Unsigned_32; + begin + if Num > Abbrevs.Next_Num then + -- Not yet decoded. + Addr := Abbrevs.Next_Addr; + + while Addr < Abbrevs.Last_Addr loop + -- Read abbreviation code. + Read_ULEB128 (Addr, Code); + + if Code /= 0 then + -- Not a pad. + + -- Insert address in map. + if Abbrevs.Map = null then + if Code <= Abbrevs.Sarray'Last then + Abbrevs.Sarray (Code) := Addr; + else + raise Program_Error; + end if; + else + if Code <= Abbrevs.Map'Last then + Abbrevs.Map (Code) := Addr; + else + -- Need to expand map. + raise Program_Error; + end if; + end if; + + -- Read tag. + Read_ULEB128 (Addr, Tag); + + -- Skip child flag. + Addr := Addr + 1; + + -- Skip attribute specifications. + loop + Read_ULEB128 (Addr, Name); + Read_ULEB128 (Addr, Form); + exit when Name = 0 and Form = 0; + end loop; + + -- Found. + exit when Code = Num; + end if; + end loop; + + -- Next entry to read. + Abbrevs.Next_Addr := Addr; + end if; + + -- Set result. + if Abbrevs.Map = null then + Res := Abbrevs.Sarray (Num); + else + Res := Abbrevs.Map (Num); + end if; + end Find_Abbrev; + + procedure Read_Uns32 (Addr : in out Address; + Form : Unsigned_32; + Res : out Unsigned_32) is + begin + case Form is + when DW_FORM_Data4 => + Read_Word4 (Addr, Res); + when others => + raise Program_Error; + end case; + end Read_Uns32; + + procedure Skip_String (Addr : in out Address) is + begin + while Read_Byte (Addr) /= 0 loop + Addr := Addr + 1; + end loop; + Addr := Addr + 1; + end Skip_String; + + procedure Read_Addr (Addr : in out Address; + Res : out Address) + is + function To_Address is new Ada.Unchecked_Conversion + (Unsigned_32, Address); + V : Unsigned_32; + begin + Read_Word4 (Addr, V); + Res := To_Address (V); + end Read_Addr; + + procedure Read_Addr (Addr : in out Address; + Form : Unsigned_32; + Res : out Address) + is + begin + case Form is + when DW_FORM_Addr => + Read_Addr (Addr, Res); + when DW_FORM_String => + Res := Addr; + Skip_String (Addr); + when others => + raise Program_Error; + end case; + end Read_Addr; + + procedure Read_Ref (Addr : in out Address; + Form : Unsigned_32; + Base : Address; + Res : out Address) + is + V : Unsigned_32; + begin + case Form is + when DW_FORM_Ref4 => + Read_Word4 (Addr, V); + Res := Base + Storage_Offset (V); + when others => + raise Program_Error; + end case; + end Read_Ref; + + procedure Skip_Form (Addr : in out Address; + Form : Unsigned_32) + is + begin + case Form is + when DW_FORM_Addr => + Addr := Addr + 4; + when DW_FORM_Flag => + Addr := Addr + 1; + when DW_FORM_Block1 => + Addr := Addr + Storage_Offset (Read_Byte (Addr)) + 1; + when DW_FORM_Data1 => + Addr := Addr + 1; + when DW_FORM_Data2 => + Addr := Addr + 2; + when DW_FORM_Data4 => + Addr := Addr + 4; + when DW_FORM_Sdata + | DW_FORM_Udata => + while (Read_Byte (Addr) and 16#80#) /= 0 loop + Addr := Addr + 1; + end loop; + Addr := Addr + 1; + when DW_FORM_Ref4 => + Addr := Addr + 4; + when DW_FORM_Strp => + Addr := Addr + 4; + when DW_FORM_String => + Skip_String (Addr); + when others => + raise Program_Error; + end case; + end Skip_Form; + + procedure Find_Subprogram (Pc : Address; + Sections : Dwarf_Sections; + Res : out Symbolize_Result; + Abbrevs : in out Abbrev_Data; + Unit_Stmt_List : out Unsigned_32) + is + Base : Address; + Addr : Address; + Sect_Last_Addr : Address; + Next_Unit_Addr : Address; + + Abbrev : Address; + + Unit_Len : Unsigned_32; + Ver : Unsigned_16; + Abbrev_Off : Unsigned_32; + Ptr_Sz : Unsigned_8; + Num : Unsigned_32; + + Tag : Unsigned_32; + Abbrev_Name : Unsigned_32; + Abbrev_Form : Unsigned_32; + + Level : Unsigned_8; + + Stmt_List : Unsigned_32; + Low_Pc : Address; + High_Pc : Address; + Name : Address; + Sibling : Address; + begin + -- Initialize result. + Res := (Filename => Null_Address, + Line => 0, + Subprg_Name => Null_Address); + + Addr := Sections.Debug_Info.Vaddr; + Sect_Last_Addr := Addr + Sections.Debug_Info.Size; + + while Addr < Sect_Last_Addr loop + -- Read unit length. + Base := Addr; + Read_Word4 (Addr, Unit_Len); + Next_Unit_Addr := Addr + Storage_Offset (Unit_Len); + Read_Word2 (Addr, Ver); + Read_Word4 (Addr, Abbrev_Off); + Read_Byte (Addr, Ptr_Sz); + Level := 0; + + Init_Abbrev (Abbrevs, Sections, Storage_Offset (Abbrev_Off)); + Unit_Stmt_List := Unsigned_32'Last; + + loop + << Again >> null; + exit when Addr >= Next_Unit_Addr; + -- Read abbrev number. + Read_ULEB128 (Addr, Num); + + -- End of children. + if Num = 0 then + Level := Level - 1; + goto Again; + end if; + + Find_Abbrev (Abbrevs, Num, Abbrev); + if Abbrev = Null_Address then + -- Not found... + return; + end if; + + Read_ULEB128 (Abbrev, Tag); + if Read_Byte (Abbrev) /= 0 then + Level := Level + 1; + end if; + + -- skip child. + Abbrev := Abbrev + 1; + + -- We are only interested in a few attributes. + Stmt_List := Unsigned_32'Last; + Low_Pc := Null_Address; + High_Pc := Null_Address; + Name := Null_Address; + Sibling := Null_Address; + + loop + Read_ULEB128 (Abbrev, Abbrev_Name); + Read_ULEB128 (Abbrev, Abbrev_Form); + exit when Abbrev_Name = 0 and Abbrev_Form = 0; + case Abbrev_Name is + when DW_AT_Stmt_List => + Read_Uns32 (Addr, Abbrev_Form, Stmt_List); + when DW_AT_Low_Pc => + Read_Addr (Addr, Abbrev_Form, Low_Pc); + when DW_AT_High_Pc => + Read_Addr (Addr, Abbrev_Form, High_Pc); + when DW_AT_Name => + Read_Addr (Addr, Abbrev_Form, Name); + when DW_AT_Sibling => + Read_Ref (Addr, Abbrev_Form, Base, Sibling); + when others => + Skip_Form (Addr, Abbrev_Form); + end case; + end loop; + + case Tag is + when DW_TAG_Compile_Unit => + if Low_Pc /= Null_Address + and then High_Pc /= Null_Address + and then (Pc < Low_Pc or Pc > High_Pc) + then + -- Out of this compile unit. + Addr := Next_Unit_Addr; + exit; + end if; + Unit_Stmt_List := Stmt_List; + when DW_TAG_Subprogram => + if Low_Pc /= Null_Address + and then High_Pc /= Null_Address + and then (Pc >= Low_Pc and Pc <= High_Pc) + then + -- Found! + Res.Subprg_Name := Name; + return; + end if; + when DW_TAG_Structure_Type + | DW_TAG_Enumeration_Type => + if Sibling /= Null_Address then + Addr := Sibling; + Level := Level - 1; + end if; + when others => + null; + end case; + end loop; + end loop; + end Find_Subprogram; + + procedure Skip_Filename (Addr : in out Address) + is + File_Dir : Unsigned_32; + File_Time : Unsigned_32; + File_Len : Unsigned_32; + begin + Skip_String (Addr); + Read_ULEB128 (Addr, File_Dir); + Read_ULEB128 (Addr, File_Time); + Read_ULEB128 (Addr, File_Len); + end Skip_Filename; + + procedure Find_Lineno (Pc_Addr : Address; + Sections : Dwarf_Sections; + Res : in out Symbolize_Result; + Stmt_List : Storage_Offset) + is + Addr : Address; + Last_Addr : Address; + Next_Addr : Address; + + -- Opcode length. Use a fixed bound. + Opc_Length : array (Unsigned_8 range 1 .. 32) of Unsigned_8; + + Total_Len : Unsigned_32; + Version : Unsigned_16; + Prolog_Len : Unsigned_32; + Min_Insn_Len : Unsigned_8; + Dflt_Is_Stmt : Unsigned_8; + Line_Base : Unsigned_8; + Line_Range : Unsigned_8; + Opc_Base : Unsigned_8; + + B : Unsigned_8; + Arg : Unsigned_32; + + File_Names : Address; + + Ext_Len : Unsigned_32; + Ext_Opc : Unsigned_8; + + Last : Address; + + Pc : Address; + Line : Unsigned_32; + Line_Base2 : Unsigned_32; + New_Row : Boolean; + + File_Id : Unsigned_32; + Prev_File_Id : Unsigned_32; + Prev_Pc : Address; + Prev_Line : Unsigned_32; + begin + if Stmt_List >= Sections.Debug_Line.Size then + -- Invalid stmt list. + return; + end if; + Addr := Sections.Debug_Line.Vaddr + Stmt_List; + Last_Addr := Addr + Sections.Debug_Line.Size - Stmt_List; + + while Addr < Last_Addr loop + -- Read header. + Read_Word4 (Addr, Total_Len); + Last := Addr + Storage_Offset (Total_Len); + Read_Word2 (Addr, Version); + Read_Word4 (Addr, Prolog_Len); + Read_Byte (Addr, Min_Insn_Len); + Read_Byte (Addr, Dflt_Is_Stmt); + Read_Byte (Addr, Line_Base); + Read_Byte (Addr, Line_Range); + Read_Byte (Addr, Opc_Base); + + Prev_Pc := Null_Address; + Prev_Line := 0; + Prev_File_Id := 0; + File_Id := 0; + New_Row := False; + Pc := Null_Address; + Line := 1; + + -- Sign extend line base. + Line_Base2 := Unsigned_32 (Line_Base); + if (Line_Base and 16#80#) /= 0 then + Line_Base2 := Line_Base2 or 16#Ff_Ff_Ff_00#; + end if; + + -- Read opcodes length. + if Opc_Base > Opc_Length'Last then + raise Program_Error; + end if; + for I in 1 .. Opc_Base - 1 loop + Read_Byte (Addr, B); + Opc_Length (I) := B; + end loop; + + -- Include directories. + loop + B := Read_Byte (Addr); + exit when B = 0; + Skip_String (Addr); + end loop; + Addr := Addr + 1; + + -- Filenames. + File_Names := Addr; + loop + B := Read_Byte (Addr); + exit when B = 0; + Skip_Filename (Addr); + end loop; + Addr := Addr + 1; + + -- The debug_line 'program'. + while Addr < Last loop + -- Read opcode. + Read_Byte (Addr, B); + + if B = 0 then + -- Extended opcode. + Read_ULEB128 (Addr, Ext_Len); + Next_Addr := Addr; + Read_Byte (Addr, Ext_Opc); + Next_Addr := Next_Addr + Storage_Offset (Ext_Len); + case Ext_Opc is + when DW_LNE_End_Sequence => + New_Row := True; + when DW_LNE_Set_Address => + Read_Addr (Addr, Pc); + when others => + raise Program_Error; + end case; + pragma Assert (Addr = Next_Addr); + elsif B < Opc_Base then + -- Standard opcode. + case B is + when DW_LNS_Copy => + New_Row := True; + when DW_LNS_Advance_Pc => + Read_ULEB128 (Addr, Arg); + Pc := Pc + + Storage_Offset (Arg * Unsigned_32 (Min_Insn_Len)); + when DW_LNS_Advance_Line => + Read_SLEB128 (Addr, Arg); + Line := Line + Arg; + when DW_LNS_Const_Add_Pc => + Pc := Pc + Storage_Offset + (Unsigned_32 ((255 - Opc_Base) / Line_Range) + * Unsigned_32 (Min_Insn_Len)); + when DW_LNS_Set_File => + Read_ULEB128 (Addr, File_Id); + when others => + for J in 1 .. Opc_Length (B) loop + Read_ULEB128 (Addr, Arg); + end loop; + raise Program_Error; + end case; + else + -- Special opcode. + B := B - Opc_Base; + Pc := Pc + Storage_Offset + (Unsigned_32 (B / Line_Range) * Unsigned_32 (Min_Insn_Len)); + Line := Line + Line_Base2 + Unsigned_32 (B mod Line_Range); + New_Row := True; + end if; + + if New_Row then + New_Row := False; + if Pc_Addr >= Prev_Pc and then Pc_Addr < Pc then + Res.Line := Natural (Prev_Line); + + -- Search for filename. + if Prev_File_Id = 0 then + Addr := Null_Address; + else + Addr := File_Names; + while Prev_File_Id > 1 loop + exit when Read_Byte (Addr) = 0; + Skip_Filename (Addr); + Prev_File_Id := Prev_File_Id - 1; + end loop; + end if; + Res.Filename := Addr; + + return; + end if; + Prev_Pc := Pc; + Prev_Line := Line; + Prev_File_Id := File_Id; + end if; + end loop; + end loop; + end Find_Lineno; + + procedure Symbolize_Address (Pc : Address; + Sections : Dwarf_Sections; + Res : out Symbolize_Result) + is + Abbrevs : Abbrev_Data; + Unit_Stmt_List : Unsigned_32; + begin + Find_Subprogram (Pc, Sections, Res, Abbrevs, Unit_Stmt_List); + + if Unit_Stmt_List /= Unsigned_32'Last then + Find_Lineno (Pc, Sections, Res, Storage_Offset (Unit_Stmt_List)); + end if; + end Symbolize_Address; +end Symbolizer; diff --git a/src/ortho/mcode/symbolizer.ads b/src/ortho/mcode/symbolizer.ads new file mode 100644 index 000000000..c31b948f4 --- /dev/null +++ b/src/ortho/mcode/symbolizer.ads @@ -0,0 +1,48 @@ +-- Dwarf symbolizer. +-- 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. + +with System.Storage_Elements; +use System; use System.Storage_Elements; + +package Symbolizer is + -- Address (in memory) and size of a debug section. + type Section_Content is record + Vaddr : Address; + Size : Storage_Offset; + end record; + + -- Input sections. + type Dwarf_Sections is record + Debug_Line : Section_Content; + Debug_Info : Section_Content; + Debug_Abbrev : Section_Content; + end record; + + -- The result, using C strings. + type Symbolize_Result is record + Filename : Address; + Line : Natural; + Subprg_Name : Address; + end record; + + -- Translate PC to filename, line number and subprogram name using dwarf + -- debug infos. + procedure Symbolize_Address (Pc : Address; + Sections : Dwarf_Sections; + Res : out Symbolize_Result); +end Symbolizer; diff --git a/src/ortho/ortho_jit.ads b/src/ortho/ortho_jit.ads index 89c3663f3..76a3f2906 100644 --- a/src/ortho/ortho_jit.ads +++ b/src/ortho/ortho_jit.ads @@ -39,5 +39,9 @@ package Ortho_Jit is -- Return the name of the code generator, to be displayed by --version. function Get_Jit_Name return String; -end Ortho_Jit; + procedure Symbolize (Pc : Address; + Filename : out Address; + Lineno : out Natural; + Subprg : out Address); +end Ortho_Jit; |