From 22793613839c9a29130f2b85832e9ec58d90562e Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sat, 5 May 2018 17:46:22 +0200 Subject: [PATCH 1/5] debugger: add option to print C backtrace Split si_dump_c_backtrace up into two functions: - _ecl_dump_c_backtrace() (already declared in internal.h, but not implemented) using only C functions printing to stderr to be used in case of internal errors - si_dump_c_backtrace() using lisp functions to be used in the debugger Remove broken emulation of backtrace and backtrace_symbols functions using __builtin_return_address. --- src/c/error.d | 2 +- src/c/ffi/backtrace.d | 105 +++++++++--------------------------------- src/h/external.h | 1 - src/lsp/top.lsp | 85 +++++++++++++++++++--------------- 4 files changed, 71 insertions(+), 122 deletions(-) diff --git a/src/c/error.d b/src/c/error.d index d0dc16881..8e9ea3fa0 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -54,7 +54,7 @@ ecl_internal_error(const char *s) strerror(saved_errno)); } fflush(stderr); - si_dump_c_backtrace(ecl_make_fixnum(32)); + _ecl_dump_c_backtrace(); #ifdef SIGIOT signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */ #endif diff --git a/src/c/ffi/backtrace.d b/src/c/ffi/backtrace.d index ce4b8d655..4c5a9eb08 100644 --- a/src/c/ffi/backtrace.d +++ b/src/c/ffi/backtrace.d @@ -14,82 +14,31 @@ #include #include -#ifdef HAVE_DLADDR -# ifdef HAVE_DLFCN_H -# include -# endif -#endif - #if defined(HAVE_BACKTRACE) || defined(HAVE_BACKTRACE_SYMBOLS) # include #endif -#if !defined(HAVE_BACKTRACE) && defined(HAVE___BUILTIN_RETURN_ADDRESS) -#define HAVE_BACKTRACE -static int -backtrace(void **buffer, int n) -{ - int nframes = (n > 32)? 32 : n; - int i; - switch (nframes) { - case 32: buffer[31] = __builtin_return_address(31); - case 31: buffer[30] = __builtin_return_address(30); - case 30: buffer[29] = __builtin_return_address(29); - case 29: buffer[28] = __builtin_return_address(28); - case 28: buffer[27] = __builtin_return_address(27); - case 27: buffer[26] = __builtin_return_address(26); - case 26: buffer[25] = __builtin_return_address(25); - case 25: buffer[24] = __builtin_return_address(24); - case 24: buffer[23] = __builtin_return_address(23); - case 23: buffer[22] = __builtin_return_address(22); - case 22: buffer[21] = __builtin_return_address(21); - case 21: buffer[20] = __builtin_return_address(20); - case 20: buffer[19] = __builtin_return_address(19); - case 19: buffer[18] = __builtin_return_address(18); - case 18: buffer[17] = __builtin_return_address(17); - case 17: buffer[16] = __builtin_return_address(16); - case 16: buffer[15] = __builtin_return_address(15); - case 15: buffer[14] = __builtin_return_address(14); - case 14: buffer[13] = __builtin_return_address(13); - case 13: buffer[12] = __builtin_return_address(12); - case 12: buffer[11] = __builtin_return_address(11); - case 11: buffer[10] = __builtin_return_address(10); - case 10: buffer[9] = __builtin_return_address(9); - case 9: buffer[8] = __builtin_return_address(8); - case 8: buffer[7] = __builtin_return_address(7); - case 7: buffer[6] = __builtin_return_address(6); - case 6: buffer[5] = __builtin_return_address(5); - case 5: buffer[4] = __builtin_return_address(4); - case 4: buffer[3] = __builtin_return_address(3); - case 3: buffer[2] = __builtin_return_address(2); - case 2: buffer[1] = __builtin_return_address(1); - case 1: buffer[0] = __builtin_return_address(0); - } - return nframes; -} -#endif +#define MAX_BACKTRACE_SIZE 128 -#if !defined(HAVE_BACKTRACE_SYMBOLS) -# if defined(HAVE_BACKTRACE) && defined(HAVE_DLADDR) -# define HAVE_BACKTRACE_SYMBOLS -# define BACKTRACE_SYMBOLS_SIMPLE -static char ** -backtrace_symbols(void **buffer, int nframes) +void +_ecl_dump_c_backtrace() { - Dl_info data[1]; - int i; - char **strings = malloc(nframes * sizeof(char*)); - for (i = 0; i < nframes; i++) { - if (dladdr(buffer[i], data)) { - strings[i] = data->dli_sname; - } else { - strings[i] = "unknown"; +#ifdef HAVE_BACKTRACE_SYMBOLS + { + void **pointers = malloc(sizeof(void*) * MAX_BACKTRACE_SIZE); + int nframes = backtrace(pointers, MAX_BACKTRACE_SIZE); + char **names = backtrace_symbols(pointers, nframes); + int i; + fprintf(stderr, "\n;;; ECL C Backtrace\n"); + for (i = 0; i < nframes; i++) { + fprintf(stderr, ";;; %s\n", names[i]); } + fflush(stderr); + free(names); + free(pointers); } - return strings; +#endif } -# endif /* HAVE_BACKTRACE && HAVE_DLADDR */ -#endif /* !HAVE_BACKTRACE_SYMBOLS */ cl_object si_dump_c_backtrace(cl_object size) @@ -97,29 +46,21 @@ si_dump_c_backtrace(cl_object size) cl_env_ptr the_env = ecl_process_env(); #ifdef HAVE_BACKTRACE_SYMBOLS { - void *pointers[32]; - int nframes = backtrace(pointers, 32); + cl_index nsize = ecl_to_unsigned_integer(size); + void **pointers = malloc(sizeof(void*) * nsize); + int nframes = backtrace(pointers, nsize); char **names = backtrace_symbols(pointers, nframes); int i; - fprintf(stderr, "\n;;; ECL C Backtrace\n"); + cl_format(2, ECL_T, make_constant_base_string("~&C Backtrace:~%")); for (i = 0; i < nframes; i++) { -#ifdef BACKTRACE_SYMBOLS_SIMPLE - fprintf(stderr, ";;; %4d %s (%p) \n", i, names[i], pointers[i]); -#else - fprintf(stderr, ";;; %s\n", names[i]); -#endif + cl_format(3, ECL_T, make_constant_base_string(" > ~a~%"), + make_constant_base_string(names[i])); } - fflush(stderr); free(names); + free(pointers); } ecl_return1(the_env, ECL_T); #else ecl_return1(the_env, ECL_NIL); #endif } - -cl_object -si_backtrace(cl_object start, cl_object end) -{ - @(return ECL_NIL); -} diff --git a/src/h/external.h b/src/h/external.h index 755cbbaa0..f1e7a72ce 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -632,7 +632,6 @@ extern ECL_API cl_object si_mmap_array(cl_object map); /* ffi/backtrace.d */ extern ECL_API cl_object si_dump_c_backtrace(cl_object size); -extern ECL_API cl_object si_backtrace(cl_object start, cl_object end); /* ffi.c */ diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 493ca8ec1..f8c0b9202 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -55,33 +55,33 @@ (defconstant tpl-commands '(("Top level commands" ((:cf :compile-file) tpl-compile-command :string - ":cf Compile file" + ":cf Compile file" ":compile-file &string &rest files [Top level command]~@ :cf &string &rest files [Abbreviation]~@ ~@ Compile files. With no arguments, uses values from latest :cf~@ command. File extensions are optional.~%") ((:exit :eof) quit :eval - ":exit Exit Lisp" + ":exit Exit Lisp" ":exit &eval &optional (status 0) [Top level command]~@ ~@ Exit Lisp without further confirmation.~%") ((:ld :load) tpl-load-command :string - ":ld Load file" + ":ld Load file" ":load &string &rest files [Top level command]~@ :ld &string &rest files [Abbreviation]~@ ~@ Load files. With no arguments, uses values from latest :ld~@ or :cf command. File extensions are optional.~%") ((:step) tpl-step-command nil - ":step Single step form" + ":step Single step form" ":step form [Top level command]~@ ~@ Evaluate form in single step mode. While stepping, a new break~@ level is invoked before every evaluation. Extra commands are~@ available at this time to control stepping and form evaluation.~%") ((:tr :trace) tpl-trace-command nil - ":tr(ace) Trace function" + ":tr(ace) Trace function" ":trace &rest functions [Top level command]~@ :tr &rest functions [Abbreviation]~@ ~@ @@ -90,7 +90,7 @@ ~@ See also: :untrace.~%") ((:untr :untrace) tpl-untrace-command nil - ":untr(ace) Untrace function" + ":untr(ace) Untrace function" ":untrace &rest functions [Top level command]~@ :untr &rest functions [Abbreviation]~@ ~@ @@ -100,7 +100,7 @@ See also: :trace.~%") #+threads ((:s :switch) tpl-switch-command nil - ":s(witch) Switch to next process to debug" + ":s(witch) Switch to next process to debug" ":switch process [Break command]~@ :s processs [Abbreviation]~@ ~@ @@ -109,7 +109,7 @@ of the process in the debugger waiting list.~%") #+threads ((:br :break) tpl-interrupt-command nil - ":br(eak) Stop a given process" + ":br(eak) Stop a given process" ":break process [Break command]~@ :br processs [Abbreviation]~@ ~@ @@ -118,7 +118,7 @@ of the process in the debugger waiting list (:waiting).~%") #+threads ((:w :waiting) tpl-waiting-command nil - ":w(aiting) Display list of active toplevels" + ":w(aiting) Display list of active toplevels" ":waiting [Break command]~@ :w [Abbreviation]~@ ~@ @@ -126,19 +126,19 @@ ) ("Help commands" ((:apropos) tpl-apropos-command nil - ":apropos Apropos" + ":apropos Apropos" ":apropos string &optional package [Top level command]~@ ~@ Finds all available symbols whose print names contain string.~@ If a non NIL package is specified, only symbols in that package are considered.~@ ~%") ((:doc document) tpl-document-command nil - ":doc(ument) Document" + ":doc(ument) Document" ":document symbol [Top level command]~@ ~@ Displays documentation about function, print names contain string.~%") ((? :h :help) tpl-help-command nil - ":h(elp) or ? Help. Type \":help help\" for more information" + ":h(elp) or ? Help. Type \":help help\" for more information" ":help &optional topic [Top level command]~@ :h &optional topic [Abbreviation]~@ ~@ @@ -168,20 +168,20 @@ (defconstant break-commands '("Break commands" ((:q :quit) tpl-quit-command nil - ":q(uit) Return to some previous break level" + ":q(uit) Return to some previous break level" ":quit &optional n [Break command]~@ :q &optional n [Abbreviation]~@ ~@ Without argument, return to top level;~@ otherwise return to break level n.~%") ((:pop) (tpl-pop-command) :constant - ":pop Pop to previous break level" + ":pop Pop to previous break level" ":pop [Break command]~@ ~@ Pop to previous break level, or if already in top level,~@ exit Lisp after confirmation.~%") ((:c :continue) continue nil - ":c(ontinue) Continue execution" + ":c(ontinue) Continue execution" ":continue [Break command]~@ :c [Abbreviation]~@ ~@ @@ -189,7 +189,7 @@ This command is only available when the break level is continuable~@ (e.g., called from a correctable error or the function break).~%") ((:b :backtrace) tpl-backtrace nil - ":b(acktrace) Print backtrace" + ":b(acktrace) Print backtrace" ":backtrace &optional n [Break command]~@ :b &optional n [Abbreviation]~@ ~@ @@ -202,7 +202,7 @@ ~@ See also: :function, :previous, :next.~%") ((:f :function) tpl-print-current nil - ":f(unction) Show current function" + ":f(unction) Show current function" ":function [Break command]~@ :f [Abbreviation]~@ ~@ @@ -213,7 +213,7 @@ ~@ See also: :backtrace, :next, previous, :disassemble, :variables.~%") ((:p :previous) tpl-previous nil - ":p(revious) Go to previous function" + ":p(revious) Go to previous function" ":previous &optional (n 1) [Break command]~@ :p &optional (n 1) [Abbreviation]~@ ~@ @@ -222,11 +222,11 @@ ~@ See also: :backtrace, :function, :go, :next.~%") ((:d :down) tpl-previous nil - ":d(own) Alias to :previous" + ":d(own) Alias to :previous" "" ) ((:n :next) tpl-next nil - ":n(ext) Go to next function" + ":n(ext) Go to next function" ":next &optional (n 1) [Break command]~@ :n &optional (n 1) [Abbreviation]~@ ~@ @@ -235,18 +235,18 @@ ~@ See also: :backtrace, :function, :go, :previous.~%") ((:u :up) tpl-next nil - ":u(p) Alias to :next" + ":u(p) Alias to :next" "" ) ((:g :go) tpl-go nil - ":g(o) Go to next function" + ":g(o) Go to next function" ":go &optional (n 1) [Break command]~@ :g &optional (n 1) [Abbreviation]~@ ~@ Move to the function at IHS[i].~@ See also: :backtrace, :function, :next, :previous.~%") ((:fs :forward-search) tpl-forward-search :string - ":fs Search forward for function" + ":fs Search forward for function" ":forward-search &string substring [Break command]~@ :fs &string substring [Abbreviation]~@ ~@ @@ -255,7 +255,7 @@ ~@ See also: :backtrace, :function, :next.~%") ((:bs :backward-search) tpl-backward-search :string - ":bs Search backward for function" + ":bs Search backward for function" ":backward-search &string substring [Break command]~@ :bs &string substring [Abbreviation]~@ ~@ @@ -264,7 +264,7 @@ ~@ See also: :backtrace, :function, :previous.~%") ((:disassemble) tpl-disassemble-command nil - ":disassemble Disassemble current function" + ":disassemble Disassemble current function" ":disassemble [Break command]~@ :disassemble [Abbreviation]~@ ~@ @@ -278,7 +278,7 @@ Show the lisp code of the current function. Only works for interpreted~@ functions.~%") ((:v :variables) tpl-variables-command nil - ":v(ariables) Show local variables, functions, blocks, and tags" + ":v(ariables) Show local variables, functions, blocks, and tags" ":variables &optional no-values [Break command]~@ :v &optional no-values [Abbreviation]~@ ~@ @@ -288,7 +288,7 @@ unless the argument is non-null.~%") #| ((:l :local) tpl-local-command nil - ":l(ocal) Return the nth local value on the stack" + ":l(ocal) Return the nth local value on the stack" ":local &optional (n 0) [Break command]~@ :l &optional (n 0) [Abbreviation] ~@ @@ -297,14 +297,14 @@ level as well as saved in the variable *.~%") |# ((:hide) tpl-hide nil - ":hide Hide function" + ":hide Hide function" ":hide function [Break command]~@ ~@ Hide function. A hidden function is not displayed in a backtrace.~@ ~@ See also: :backtrace, :unhide, :hide-package.~%") ((:unhide) tpl-unhide nil - ":unhide Unhide function" + ":unhide Unhide function" ":unhide function [Break command]~@ ~@ Unhide function. The specified function will be displayed in future~@ @@ -312,7 +312,7 @@ ~@ See also: :backtrace, :hide, :unhide-package.~%") ((:hp :hide-package) tpl-hide-package nil - ":hp Hide package" + ":hp Hide package" ":hide-package package [Break command]~@ :hp package [Abbreviation]~@ ~@ @@ -321,7 +321,7 @@ ~@ See also: :backtrace, :unhide-package.~%") ((:unhp :unhide-package) tpl-unhide-package nil - ":unhp Unhide package" + ":unhp Unhide package" ":unhide-package package [Break command]~@ :unhp package [Abbreviation]~@ ~@ @@ -330,7 +330,7 @@ ~@ See also: :backtrace, :hide-package, :hide, :unhide.~%") ((:unhide-all) tpl-unhide-all nil - ":unhide-all Unhide all variables and packages" + ":unhide-all Unhide all variables and packages" ":unhide-all [Break command]~@ ~@ Unhide all variables and packages. All functions will be displayed~@ @@ -339,7 +339,7 @@ See also: :hide, :unhide, :hide-package, :unhide-package.~%") #| ((:vs :value-stack) tpl-vs-command nil - ":vs Show value stack" + ":vs Show value stack" ":value-stack &optional n [Break command]~@ :vs &optional n [Abbreviation]~@ ~@ @@ -350,7 +350,7 @@ See also: :local.~%") |# ((:bds :binding-stack) tpl-bds-command nil - ":bds Show binding stack" + ":bds Show binding stack" ":binding-stack &optional variable [Break command]~@ :bds &optional variable [Abbreviation]~@ ~@ @@ -358,23 +358,23 @@ break level. With a variable name, print nothing, but return the~@ value of the given variable on the binding stack.~%") ((:frs :frame-stack) tpl-frs-command nil - ":frs Show frame stack" + ":frs Show frame stack" "" ) ((:m :message) tpl-print-message nil - ":m(essage) Show error message" + ":m(essage) Show error message" ":message [Break command]~@ :m [Abbreviation]~@ ~@ Show current error message.~%") ((:hs :help-stack) tpl-help-stack-command nil - ":hs Help stack" + ":hs Help stack" ":help-stack [Break command]~@ :hs [Abbreviation]~@ ~@ Lists the functions to access the LISP system stacks.~%") ((:i :inspect) tpl-inspect-command nil - ":i(nspect) Inspect value of local variable" + ":i(nspect) Inspect value of local variable" ":inspect var-name [Break command]~@ :i var-name [Abbreviation]~@ ~@ @@ -383,6 +383,15 @@ then be used regardless of of the symbol's package.~@ ~@ See also: :variables.~%") + ((:cb :c-backtrace) ext::dump-c-backtrace nil + ":c(-)b(acktrace) Print a raw C backtrace" + ":c-backtrace n [Break command]~@ + :cb n [Abbreviation]~@ + ~@ + Show function call history of the n C functions above and~@ + including the current one.~@ + ~@ + See also: :backtrace.~%") )) (defparameter *lisp-initialized* nil) From a3a44a0eeb7a3d472e916af6fda184ade7b6a625 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 6 May 2018 14:28:08 +0200 Subject: [PATCH 2/5] debugger: add C backtrace for windows Because that needs the DbgHelp library, an additional make option has been defined for users, who don't want to link to this library. Some msvc Makefile cleanup has also been done. --- msvc/Makefile | 22 ++++++--- msvc/c/Makefile | 22 ++++++--- msvc/ecl/config-internal.h.msvc6 | 5 +++ src/c/ffi/backtrace.d | 77 +++++++++++++++++++++++++++++--- 4 files changed, 107 insertions(+), 19 deletions(-) diff --git a/msvc/Makefile b/msvc/Makefile index 8d159786f..5ab61530f 100755 --- a/msvc/Makefile +++ b/msvc/Makefile @@ -60,6 +60,8 @@ ECL_RT = ECL_DEFSYS = # Profiling ECL_PROFILE = +# Use the DbgHelp.lib shared library to provide C Backtrace support +ECL_USE_DBGHELP = $(ECL_DEBUG) !if "$(YASM)" == "" !if "$(ECL_WIN64)" != "" @@ -78,7 +80,9 @@ TAR_DIR = %CD%\ecl-$(ECL_VERSION) # CC = cl -LIBS = eclgc.lib eclgmp.lib user32.lib ws2_32.lib shell32.lib +CLIBS = user32.lib ws2_32.lib shell32.lib +STATICLIBS = eclgc.lib eclgmp.lib +LIBS = $(STATICLIBS) $(CLIBS) RM = del RMDIR = rmdir /Q /S MKDIR = mkdir @@ -123,6 +127,10 @@ SHARED_LDFLAGS = /LD GCFLAGS = nodebug=1 !endif +!if "$(ECL_USE_DBGHELP)" != "" +CLIBS = $(CLIBS) DbgHelp.lib +!endif + CFLAGS = /EHsc /DGC_DLL /DGC_BUILD /nologo /D_CRT_SECURE_NO_DEPRECATE $(CFLAGS_CONFIG) LDFLAGS = /link /incremental:no /nologo /nodefaultlib:libcmt /nodefaultlib:libcmtd /nodefaultlib:libc /nodefaultlib:libcd $(LDFLAGS_CONFIG) @@ -263,9 +271,9 @@ compile.lsp: bare.lsp $(srcdir)/compile.lsp.in Makefile "@LDFLAGS@" "$(LDFLAGS)" \ "@SHARED_LDFLAGS@" "$(SHARED_LDFLAGS)" \ "@BUNDLE_LDFLAGS@" "$(SHARED_LDFLAGS)" \ - "@CLIBS@" "user32.lib ws2_32.lib shell32.lib" \ - "@STATICLIBS@" "eclgmp.lib eclgc.lib" \ - "@LIBS@" "user32.lib ws2_32.lib shell32.lib" \ + "@CLIBS@" "$(CLIBS)" \ + "@STATICLIBS@" "$(STATICLIBS)" \ + "@LIBS@" "$(LIBS)" \ "@CORE_LIBS@" "" \ "@FASL_LIBS@" "" \ "@OBJEXT@" "obj" \ @@ -305,8 +313,8 @@ cmp/cmpdefs.lsp: $(srcdir)/cmp/cmpdefs.lsp Makefile "@LDFLAGS@" "$(LDFLAGS)" \ "@SHARED_LDFLAGS@" "$(SHARED_LDFLAGS)" \ "@BUNDLE_LDFLAGS@" "$(SHARED_LDFLAGS)" \ - "@CLIBS@" "user32.lib ws2_32.lib shell32.lib" \ - "@STATICLIBS@" "eclgmp.lib eclgc.lib" \ + "@CLIBS@" "$(CLIBS)" \ + "@STATICLIBS@" "$(STATICLIBS)" \ "@OBJEXT@" "obj" \ "@SHAREDPREFIX@" "" \ "@SHAREDEXT@" "dll" \ @@ -340,6 +348,7 @@ eclmin.lib: eclgmp.lib eclgc.lib lsp/config.lsp $(MAKE) ECL_VERSION_NUMBER=$(ECL_VERSION_NUMBER) \ ECL_THREADS=$(ECL_THREADS) ECL_UNICODE=$(ECL_UNICODE) \ ECL_SSE=$(ECL_SSE) ECL_WIN64=$(ECL_WIN64) \ + ECL_USE_DBGHELP=$(ECL_USE_DBGHELP) \ "ECL_CFLAGS=$(CFLAGS) -DGC_BUILD" cd .. eclgc.lib: @@ -448,6 +457,7 @@ clean_ecl: -$(MAKE) ECL_VERSION_NUMBER=$(ECL_VERSION_NUMBER) \ ECL_THREADS=$(ECL_THREADS) ECL_UNICODE=$(ECL_UNICODE) \ ECL_SSE=$(ECL_SSE) ECL_WIN64=$(ECL_WIN64) \ + ECL_USE_DBGHELP=$(ECL_USE_DBGHELP) \ "ECL_CFLAGS=$(CFLAGS) -DGC_BUILD" clean cd .. clean_lisp: diff --git a/msvc/c/Makefile b/msvc/c/Makefile index ec87976a1..15a594f1c 100755 --- a/msvc/c/Makefile +++ b/msvc/c/Makefile @@ -35,6 +35,12 @@ ECL_SSE_FLAG=0 ECL_SSE_OBJ= !endif +!if "$(ECL_USE_DBGHELP)" != "" +ECL_USE_DBGHELP_FLAG=1 +!else +ECL_USE_DBGHELP_FLAG=0 +!endif + # Programs used by "make": # TRUE_CC = cl @@ -60,12 +66,14 @@ libdir=$(prefix)\lib\ecl # Files HDIR = $(top_srcdir)\h -HFILES = ..\ecl\config.h ..\ecl\atomic_ops.h $(HDIR)\ecl.h $(HDIR)\ecl-cmp.h\ - $(HDIR)\object.h $(HDIR)\cs.h $(HDIR)\stacks.h\ - $(HDIR)\external.h $(HDIR)\cons.h $(HDIR)\legacy.h\ +HFILES = ..\ecl\config.h ..\ecl\config-internal.h ..\ecl\atomic_ops.h \ + $(HDIR)\ecl.h $(HDIR)\ecl-cmp.h \ + $(HDIR)\object.h $(HDIR)\cs.h $(HDIR)\stacks.h \ + $(HDIR)\external.h $(HDIR)\cons.h $(HDIR)\legacy.h \ $(HDIR)\number.h $(HDIR)\page.h \ $(HDIR)\internal.h $(HDIR)\ecl-inl.h $(HDIR)\bytecodes.h \ - $(HDIR)\impl\math_dispatch.h + $(HDIR)\impl\math_dispatch.h $(HDIR)\cache.h $(HDIR)\stack-resize.h \ + $(HDIR)\ecl-atomic-ops.h OBJS = main.obj symbol.obj package.obj cons.obj list.obj\ apply.obj eval.obj \ @@ -153,21 +161,23 @@ clean: # Build rules -$(DPP): $(srcdir)/dpp.c $(srcdir)/symbols_list2.h ../ecl/config.h +$(DPP): $(srcdir)/dpp.c $(srcdir)/symbols_list2.h ../ecl/config.h ../ecl/config-internal.h $(TRUE_CC) -I.. -I./ $(srcdir)/dpp.c -o $@ -$(HFILES): ../ecl/config.h.msvc6 Makefile +$(HFILES): ../ecl/config.h.msvc6 ../ecl/config-internal.h.msvc6 Makefile -mkdir ..\ecl\impl cut.exe "@ECL_FPE_CODE@" "$(srcdir:\=/)/arch/$(ECL_FPE_CODE)" \ "@ECL_VERSION_NUMBER@" "$(ECL_VERSION_NUMBER)" \ "@ECL_THREADS@" "$(ECL_THREADS_FLAG)" \ "@ECL_UNICODE@" "$(ECL_UNICODE_FLAG)" \ "@ECL_SSE2@" "$(ECL_SSE_FLAG)" \ + "@ECL_USE_DBGHELP@" "$(ECL_USE_DBGHELP_FLAG)" \ < ..\ecl\config.h.msvc6 > ..\ecl\config.h cut.exe "@ECL_FPE_CODE@" "$(srcdir:\=/)/arch/$(ECL_FPE_CODE)" \ "@ECL_VERSION_NUMBER@" "$(ECL_VERSION_NUMBER)" \ "@ECL_THREADS@" "$(ECL_THREADS_FLAG)" \ "@ECL_UNICODE@" "$(ECL_UNICODE_FLAG)" \ "@ECL_SSE2@" "$(ECL_SSE_FLAG)" \ + "@ECL_USE_DBGHELP@" "$(ECL_USE_DBGHELP_FLAG)" \ < ..\ecl\config-internal.h.msvc6 > ..\ecl\config-internal.h xcopy /SYI $(top_srcdir)\h\*.h ..\ecl -mkdir ..\ecl\atomic_ops diff --git a/msvc/ecl/config-internal.h.msvc6 b/msvc/ecl/config-internal.h.msvc6 index 18694fcef..758d3977a 100644 --- a/msvc/ecl/config-internal.h.msvc6 +++ b/msvc/ecl/config-internal.h.msvc6 @@ -210,3 +210,8 @@ # define ECL_MATHERR_CLEAR # define ECL_MATHERR_TEST #endif + +#define ECL_WINDOWS_BACKTRACE @ECL_USE_DBGHELP@ +#if !ECL_WINDOWS_BACKTRACE +#undef ECL_WINDOWS_BACKTRACE +#endif diff --git a/src/c/ffi/backtrace.d b/src/c/ffi/backtrace.d index 4c5a9eb08..1bdcb8f49 100644 --- a/src/c/ffi/backtrace.d +++ b/src/c/ffi/backtrace.d @@ -14,53 +14,116 @@ #include #include -#if defined(HAVE_BACKTRACE) || defined(HAVE_BACKTRACE_SYMBOLS) +#if defined(HAVE_BACKTRACE) && defined(HAVE_BACKTRACE_SYMBOLS) # include +# define ECL_UNIX_BACKTRACE #endif +#if defined(ECL_WINDOWS_BACKTRACE) +# include +# include +#endif + +/* Max number of frames dumped by _ecl_dump_c_backtrace */ #define MAX_BACKTRACE_SIZE 128 +/* Max length of symbols printed */ +#define MAX_SYMBOL_LENGTH 256 void _ecl_dump_c_backtrace() { -#ifdef HAVE_BACKTRACE_SYMBOLS +#if defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) { void **pointers = malloc(sizeof(void*) * MAX_BACKTRACE_SIZE); +# if defined(ECL_UNIX_BACKTRACE) int nframes = backtrace(pointers, MAX_BACKTRACE_SIZE); char **names = backtrace_symbols(pointers, nframes); +# elif defined(ECL_WINDOWS_BACKTRACE) + HANDLE process = GetCurrentProcess(); + if (!SymInitialize(process, NULL, TRUE)) { + return; + } + int nframes = CaptureStackBackTrace(0, MAX_BACKTRACE_SIZE, pointers, NULL); + char buffer[sizeof(SYMBOL_INFO) + MAX_SYMBOL_LENGTH * sizeof(TCHAR)]; + PSYMBOL_INFO pSymbol = (PSYMBOL_INFO)buffer; + pSymbol->SizeOfStruct = sizeof(SYMBOL_INFO); + pSymbol->MaxNameLen = MAX_SYMBOL_LENGTH; +# endif int i; fprintf(stderr, "\n;;; ECL C Backtrace\n"); for (i = 0; i < nframes; i++) { +# if defined(ECL_UNIX_BACKTRACE) fprintf(stderr, ";;; %s\n", names[i]); +# elif defined(ECL_WINDOWS_BACKTRACE) + DWORD64 displacement; + if (SymFromAddr(process, (DWORD64) pointers[i], &displacement, pSymbol)) { + fprintf(stderr, ";;; (%s+0x%llx) [0x%p]\n", pSymbol->Name, displacement, pointers[i]); + } else { + fprintf(stderr, ";;; (unknown) [0x%p]\n", pointers[i]); + } +# endif } fflush(stderr); - free(names); free(pointers); +# if defined(ECL_UNIX_BACKTRACE) + free(names); +# elif defined(ECL_WINDOWS_BACKTRACE) + SymCleanup(process); +# endif } -#endif +#endif /* defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) */ } cl_object si_dump_c_backtrace(cl_object size) { cl_env_ptr the_env = ecl_process_env(); -#ifdef HAVE_BACKTRACE_SYMBOLS +#if defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) { cl_index nsize = ecl_to_unsigned_integer(size); void **pointers = malloc(sizeof(void*) * nsize); +# if defined(ECL_UNIX_BACKTRACE) int nframes = backtrace(pointers, nsize); char **names = backtrace_symbols(pointers, nframes); +# elif defined(ECL_WINDOWS_BACKTRACE) + HANDLE process = GetCurrentProcess(); + if (!SymInitialize(process, NULL, TRUE)) { + return; + } + int nframes = CaptureStackBackTrace(0, nsize, pointers, NULL); + char buffer[sizeof(SYMBOL_INFO) + MAX_SYMBOL_LENGTH * sizeof(TCHAR)]; + PSYMBOL_INFO pSymbol = (PSYMBOL_INFO)buffer; + pSymbol->SizeOfStruct = sizeof(SYMBOL_INFO); + pSymbol->MaxNameLen = MAX_SYMBOL_LENGTH; +# endif int i; cl_format(2, ECL_T, make_constant_base_string("~&C Backtrace:~%")); for (i = 0; i < nframes; i++) { +# if defined(ECL_UNIX_BACKTRACE) cl_format(3, ECL_T, make_constant_base_string(" > ~a~%"), make_constant_base_string(names[i])); +# elif defined(ECL_WINDOWS_BACKTRACE) + DWORD64 displacement; + if (SymFromAddr(process, (DWORD64) pointers[i], &displacement, pSymbol)) { + cl_format(5, ECL_T, make_constant_base_string(" > (~a+0x~x) [0x~x]~%"), + make_constant_base_string(pSymbol->Name), + ecl_make_unsigned_integer(displacement), + ecl_make_unsigned_integer((cl_index)pointers[i])); + } else { + cl_format(3, ECL_T, make_constant_base_string(" > (unknown) [0x~x]~%"), + ecl_make_unsigned_integer((cl_index)pointers[i])); + } +# endif } - free(names); free(pointers); +# if defined(ECL_UNIX_BACKTRACE) + free(names); +# elif defined(ECL_WINDOWS_BACKTRACE) + SymCleanup(process); +# endif } ecl_return1(the_env, ECL_T); #else ecl_return1(the_env, ECL_NIL); -#endif +#endif /* defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) */ } From b87fc19afb4f33e0cb8ae5c5b4611cc6c9ca6878 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 6 May 2018 15:18:22 +0200 Subject: [PATCH 3/5] remove no longer needed checks in configure.ac --- src/aclocal.m4 | 16 ---------------- src/configure | 29 +---------------------------- src/configure.ac | 11 +++++------ src/ecl/configpre.h | 6 ------ src/h/config-internal.h.in | 2 -- 5 files changed, 6 insertions(+), 58 deletions(-) diff --git a/src/aclocal.m4 b/src/aclocal.m4 index f4e4527ef..82bce9eca 100644 --- a/src/aclocal.m4 +++ b/src/aclocal.m4 @@ -831,22 +831,6 @@ AC_MSG_CHECKING([Linker flags]) AC_MSG_RESULT([${LDFLAGS}]) ]) -dnl -------------------------------------------------------------- -dnl Determine whether GCC supports backtraces -dnl -AC_DEFUN([ECL_GCC_BACKTRACE],[ -if test "x${cross_compiling}" != "xyes"; then -AC_RUN_IFELSE( - [AC_LANG_SOURCE([[ - void *foo() { return __builtin_return_address(1); } - int main() { - return (foo() == 0); - }]])], - [AC_DEFINE([HAVE___BUILTIN_RETURN_ADDRESS], [], [HAVE___BUILTIN_RETURN_ADDRESS])], - []) -fi -]) - dnl ---------------------------------------------------------------------- dnl Choose the type of code to detect floating point exceptions and dnl raise them. diff --git a/src/configure b/src/configure index 7c773b7ba..be59f62d0 100755 --- a/src/configure +++ b/src/configure @@ -9341,7 +9341,7 @@ fi done -for ac_func in sched_yield uname fseeko dladdr backtrace backtrace_symbols +for ac_func in sched_yield uname fseeko backtrace backtrace_symbols do : as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" @@ -9422,33 +9422,6 @@ $as_echo "#define ECL_CXX_CORE 1" >>confdefs.h fi -if test "x${cross_compiling}" != "xyes"; then -if test "$cross_compiling" = yes; then : - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot run test program while cross compiling -See \`config.log' for more details" "$LINENO" 5; } -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - - void *foo() { return __builtin_return_address(1); } - int main() { - return (foo() == 0); - } -_ACEOF -if ac_fn_c_try_run "$LINENO"; then : - -$as_echo "#define HAVE___BUILTIN_RETURN_ADDRESS /**/" >>confdefs.h - -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - -fi - - case "${enable_libatomic}" in auto|system|included) ;; *) as_fn_error $? "Invalid value of --enable-libatomic: ${enable_libatomic} " "$LINENO" 5;; diff --git a/src/configure.ac b/src/configure.ac index 162b9b8e3..6d50435ec 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -185,15 +185,15 @@ AC_ARG_WITH(bytecmp, AC_ARG_WITH(rt, AS_HELP_STRING( [--with-rt], - [Deprecated! include MIT-RT testing environment] - [(yes|builtin|no, default=NO)]), - [], [with_rt=no]) + [include MIT-RT testing environment] + [(yes|builtin|no, default=YES)]), + [], [with_rt=yes]) AC_ARG_WITH(profile, AS_HELP_STRING( [--with-profile], - [Deprecated! include CMUCL's simple profiler] + [include CMUCL's simple profiler] [(yes|builtin|no, default=YES if Boehm-Weiser garbage collector used)]), - [], [with_profile=NO]) + [], [with_profile=yes]) AC_ARG_WITH(dffi, AS_HELP_STRING( [--with-dffi], @@ -752,7 +752,6 @@ else boehm_configure_flags="${boehm_configure_flags} --enable-cplusplus" fi -ECL_GCC_BACKTRACE ECL_LIBATOMIC_OPS dnl ---------------------------------------------------------------------- diff --git a/src/ecl/configpre.h b/src/ecl/configpre.h index 2aa0c57bd..f1681d1ec 100644 --- a/src/ecl/configpre.h +++ b/src/ecl/configpre.h @@ -102,9 +102,6 @@ /* Define to 1 if you have the header file. */ #undef HAVE_DIRENT_H -/* Define to 1 if you have the `dladdr' function. */ -#undef HAVE_DLADDR - /* Define to 1 if you have the header file. */ #undef HAVE_DLFCN_H @@ -431,9 +428,6 @@ /* Define to 1 if the system has the type `_Bool'. */ #undef HAVE__BOOL -/* HAVE___BUILTIN_RETURN_ADDRESS */ -#undef HAVE___BUILTIN_RETURN_ADDRESS - /* Define to 1 if `lstat' dereferences a symlink specified with a trailing slash. */ #undef LSTAT_FOLLOWS_SLASHED_SYMLINK diff --git a/src/h/config-internal.h.in b/src/h/config-internal.h.in index edffb87f3..2111d7df8 100644 --- a/src/h/config-internal.h.in +++ b/src/h/config-internal.h.in @@ -161,10 +161,8 @@ /* existence of char **environ */ #undef HAVE_ENVIRON /* existence of pointer -> function name functions */ -#undef HAVE_DLADDR #undef HAVE_BACKTRACE #undef HAVE_BACKTRACE_SYMBOLS -#undef HAVE___BUILTIN_RETURN_ADDRESS #undef HAVE_SCHED_H /* From d4370d1b3180a2b79cee85622804f90fd8d1f8a9 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Tue, 8 May 2018 19:24:03 +0200 Subject: [PATCH 4/5] re-add deprecation of rt and profile (rebase thing) --- src/configure | 7 +++---- src/configure.ac | 12 ++++++------ src/ecl/configpre.h | 3 +++ 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/src/configure b/src/configure index be59f62d0..be1d07b61 100755 --- a/src/configure +++ b/src/configure @@ -1521,8 +1521,7 @@ Optional Packages: --with-rt Deprecated! include MIT-RT testing environment (yes|builtin|no, default=NO) --with-profile Deprecated! include CMUCL's simple profiler - (yes|builtin|no, default=YES if Boehm-Weiser garbage - collector used) + (yes|builtin|no, default=NO) --with-dffi dynamic foreign function interface (system|included|auto|no, default=AUTO if libffi available) @@ -2859,7 +2858,7 @@ fi if test "${with_profile+set}" = set; then : withval=$with_profile; else - with_profile=NO + with_profile=no fi @@ -9341,7 +9340,7 @@ fi done -for ac_func in sched_yield uname fseeko backtrace backtrace_symbols +for ac_func in sched_yield uname fseeko dladdr backtrace backtrace_symbols do : as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" diff --git a/src/configure.ac b/src/configure.ac index 6d50435ec..297482eb0 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -185,15 +185,15 @@ AC_ARG_WITH(bytecmp, AC_ARG_WITH(rt, AS_HELP_STRING( [--with-rt], - [include MIT-RT testing environment] - [(yes|builtin|no, default=YES)]), - [], [with_rt=yes]) + [Deprecated! include MIT-RT testing environment] + [(yes|builtin|no, default=NO)]), + [], [with_rt=no]) AC_ARG_WITH(profile, AS_HELP_STRING( [--with-profile], - [include CMUCL's simple profiler] - [(yes|builtin|no, default=YES if Boehm-Weiser garbage collector used)]), - [], [with_profile=yes]) + [Deprecated! include CMUCL's simple profiler] + [(yes|builtin|no, default=NO)]), + [], [with_profile=no]) AC_ARG_WITH(dffi, AS_HELP_STRING( [--with-dffi], diff --git a/src/ecl/configpre.h b/src/ecl/configpre.h index f1681d1ec..96795696f 100644 --- a/src/ecl/configpre.h +++ b/src/ecl/configpre.h @@ -102,6 +102,9 @@ /* Define to 1 if you have the header file. */ #undef HAVE_DIRENT_H +/* Define to 1 if you have the `dladdr' function. */ +#undef HAVE_DLADDR + /* Define to 1 if you have the header file. */ #undef HAVE_DLFCN_H From 94342d2ea933d9168b2f9e110939319c105c3b96 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Tue, 8 May 2018 19:40:14 +0200 Subject: [PATCH 5/5] add changelog entry about improved C backtraces --- CHANGELOG | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG b/CHANGELOG index d2c5c2ae2..e930341e8 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -29,6 +29,7 @@ * Pending changes since 16.1.3 ** Enhancements +- improvements to C backend interface by Marius Gerbershagen - better handling of fifo files (see man 7 fifo) - unicode names are always linked for unicode builds (~--with-unicode-names~ removed) - numerous bytecodes compiler enhancements