diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 37dad8db16..f67e1dd72a 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -257,7 +257,7 @@ backtrace-mode-map map) "Local keymap for `backtrace-mode' buffers.") -(defconst backtrace--flags-width 2 +(defconst backtrace--flags-width 7 "Width in characters of the flags for a backtrace frame.") ;;; Navigation and Text Properties @@ -746,11 +746,16 @@ backtrace--print-flags "Print the flags of a backtrace FRAME if enabled in VIEW." (let ((beg (point)) (flag (plist-get (backtrace-frame-flags frame) :debug-on-exit)) - (source (plist-get (backtrace-frame-flags frame) :source-available))) + (source (plist-get (backtrace-frame-flags frame) :source-available)) + (offset (plist-get (backtrace-frame-flags frame) :bytecode-offset)) + ;; right justify and pad the offset (or the empty string) + (offset-format (format "%%%ds " (- backtrace--flags-width 3))) + (fun (ignore-errors (indirect-function (backtrace-frame-fun frame))))) (when (plist-get view :show-flags) - (when source (insert ">")) - (when flag (insert "*"))) - (insert (make-string (- backtrace--flags-width (- (point) beg)) ?\s)) + (insert (if source ">" " ")) + (insert (if flag "*" " ")) + (insert (format offset-format + (or (and (byte-code-function-p fun) offset) "")))) (put-text-property beg (point) 'backtrace-section 'func))) (defun backtrace--print-func-and-args (frame _view) diff --git a/src/bytecode.c b/src/bytecode.c index 5ac30aa101..c6766a38cf 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -311,6 +311,10 @@ #define DISCARD(n) (top -= (n)) #define TOP (*top) +/* Update the thread's bytecode offset, just before NEXT. */ + +#define UPDATE_OFFSET (backtrace_byte_offset = pc - bytestr_data - 1) + DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0, doc: /* Function used internally in byte-compiled code. The first argument, BYTESTR, is a string of byte code; @@ -618,6 +622,7 @@ #define DEFINE(name, value) LABEL (name) , op -= Bcall; docall: { + UPDATE_OFFSET; DISCARD (op); #ifdef BYTE_CODE_METER if (byte_metering_on && SYMBOLP (TOP)) @@ -1448,7 +1453,7 @@ #define DEFINE(name, value) LABEL (name) , unbind_to (count, Qnil); error ("binding stack not balanced (serious byte compiler bug)"); } - + backtrace_byte_offset = -1; Lisp_Object result = TOP; SAFE_FREE (); return result; diff --git a/src/eval.c b/src/eval.c index 959adea646..e4451aa96c 100644 --- a/src/eval.c +++ b/src/eval.c @@ -137,6 +137,13 @@ backtrace_args (union specbinding *pdl) return pdl->bt.args; } +static int +backtrace_bytecode_offset (union specbinding *pdl) +{ + eassert (pdl->kind == SPECPDL_BACKTRACE); + return pdl->bt.bytecode_offset; +} + static bool backtrace_debug_on_exit (union specbinding *pdl) { @@ -2149,6 +2156,11 @@ record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) specpdl_ptr->bt.function = function; current_thread->stack_top = specpdl_ptr->bt.args = args; specpdl_ptr->bt.nargs = nargs; + if (backtrace_byte_offset > 0) { + union specbinding *nxt = backtrace_top (); + if (backtrace_p (nxt) && nxt->kind == SPECPDL_BACKTRACE) + nxt->bt.bytecode_offset = backtrace_byte_offset; + } grow_specpdl (); return count; @@ -3650,6 +3662,10 @@ backtrace_frame_apply (Lisp_Object function, union specbinding *pdl) if (backtrace_debug_on_exit (pdl)) flags = list2 (QCdebug_on_exit, Qt); + int off = backtrace_bytecode_offset (pdl); + if (off > 0) + flags = Fcons (QCbytecode_offset, Fcons (make_fixnum (off), flags)); + if (backtrace_nargs (pdl) == UNEVALLED) return call4 (function, Qnil, backtrace_function (pdl), *backtrace_args (pdl), flags); else @@ -4237,6 +4253,7 @@ syms_of_eval (void) defsubr (&Sfetch_bytecode); defsubr (&Sbacktrace_debug); DEFSYM (QCdebug_on_exit, ":debug-on-exit"); + DEFSYM (QCbytecode_offset, ":bytecode-offset"); defsubr (&Smapbacktrace); defsubr (&Sbacktrace_frame_internal); defsubr (&Sbacktrace_frames_from_thread); diff --git a/src/lisp.h b/src/lisp.h index 3442699088..e92300f4f7 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3230,6 +3230,7 @@ #define DEFVAR_KBOARD(lname, vname, doc) \ Lisp_Object function; Lisp_Object *args; ptrdiff_t nargs; + int bytecode_offset; } bt; }; diff --git a/src/thread.h b/src/thread.h index a09929fa44..b5e3f0f9c5 100644 --- a/src/thread.h +++ b/src/thread.h @@ -103,6 +103,11 @@ #define specpdl (current_thread->m_specpdl) union specbinding *m_specpdl_ptr; #define specpdl_ptr (current_thread->m_specpdl_ptr) + /* The offset of the current op of the byte-code function being + executed. */ + int m_backtrace_byte_offset; +#define backtrace_byte_offset (current_thread->m_backtrace_byte_offset) + /* Depth in Lisp evaluations and function calls. */ intmax_t m_lisp_eval_depth; #define lisp_eval_depth (current_thread->m_lisp_eval_depth)