Re: Lisp-friendly backtraces [was: Lispy backtraces]

["Clément Pit--Claudel" <clement.pit@gmail.com>]

[-- Attachment #1.1.1: Type: text/plain, Size: 692 bytes --]

On 2016-12-05 08:20, Stefan Monnier wrote:
>> (defun backtrace ()
>>   "Print a trace of Lisp function calls currently active.
>> Output stream used is value of `standard-output'."
>>   (mapbacktrace #'~/backtrace-1 1))
> 
> Have you tried it both byte-compiled and interpreted?  Maybe this
> function is just simple enough that the result is the same in both
> cases, but in my experience, the stack is sufficiently different in the
> two cases that a constant nskip doesn't cut it (hence the use of `base`
> in backtrace-frame).

Thanks; I attached an updated patch.  Removing `backtrace' from eval.c makes the patch much harder to read, so I'll do that later.

Clément.



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.1.2: bt.el --]
[-- Type: text/x-emacs-lisp; name="bt.el", Size: 2029 bytes --]

;; -*- lexical-binding: t -*-

(defun backtrace-1 (evald func args flags)
  "Print a trace of a single stack frame to `standard-output'.
EVALD, FUNC, ARGS, FLAGS are as in `mapbacktrace'."
  (let ((print-level (or print-level 8)))
    (princ (if (plist-get flags :debug-on-exit) "* " "  "))
    (cond
     ((and evald (not debugger-stack-frame-as-list))
      (prin1 func)
      (if args (prin1 args) (princ "()")))
     (t
      (prin1 (cons func args))))
    (princ "\n")))

(defun backtrace ()
  "Print a trace of Lisp function calls currently active.
Output stream used is value of `standard-output'."
  (mapbacktrace #'backtrace-1 'backtrace))

(backtrace)

(defun backtrace-frames ()
  "Collect all frames of current backtrace into a list."
  (let ((frames nil))
    (mapbacktrace (lambda (&rest frame) (push frame frames)) 'backtrace-frames)
    (nreverse frames)))

(backtrace-frames)

(defun ~/backtrace-frame (nframes &optional base)
  "Return the function and arguments NFRAMES up from current execution point.
If that frame has not evaluated the arguments yet (or is a special form),
the value is (nil FUNCTION ARG-FORMS...).
If that frame has evaluated its arguments and called its function already,
the value is (t FUNCTION ARG-VALUES...).
A &rest arg is represented as the tail of the list ARG-VALUES.
FUNCTION is whatever was supplied as car of evaluated list,
or a lambda expression for macro calls.
If NFRAMES is more than the number of frames, the value is nil.
If BASE is non-nil, it should be a function and NFRAMES counts from its
nearest activation frame."
  (let ((frame nil))
    (mapbacktrace (lambda (evald func args _)
                    (when (and base (eq func base))
                      (setq base nil))
                    (unless base
                      (when (eq nframes 0)
                        (setq frame `(,evald ,func ,@args)))
                      (setq nframes (1- nframes))))
                  '~/backtrace-frame)
    frame))

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.1.3: 0001-New-function-mapbacktrace.patch --]
[-- Type: text/x-diff; name="0001-New-function-mapbacktrace.patch", Size: 3683 bytes --]

From 6302757b6fc664a8ef56ff8742aaf1987e58107d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Cl=C3=A9ment=20Pit--Claudel?= <clement.pitclaudel@live.com>
Date: Mon, 5 Dec 2016 00:52:14 -0500
Subject: [PATCH] New function mapbacktrace

---
 src/eval.c | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 57 insertions(+), 9 deletions(-)

diff --git a/src/eval.c b/src/eval.c
index 724f001..66b665e 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -3420,6 +3420,60 @@ The debugger is entered when that frame exits, if the flag is non-nil.  */)
   return flag;
 }
 
+static union specbinding *
+get_backtrace_starting_at (Lisp_Object base)
+{
+  union specbinding *pdl = backtrace_top ();
+
+  if (!NILP (base))
+    { /* Skip up to `base'.  */
+      base = Findirect_function (base, Qt);
+      while (backtrace_p (pdl)
+             && !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
+        pdl = backtrace_next (pdl);
+    }
+
+  return pdl;
+}
+
+DEFUN ("mapbacktrace", Fmapbacktrace, Smapbacktrace, 1, 2, 0,
+       doc: /* Call FUNCTION for each frame in backtrace.
+FUNCTION is called with 4 arguments EVALD FUNC ARGS FLAGS.  If a frame
+has not evaluated its arguments yet or is a special form, EVALD is nil
+and ARGS is a list of forms.  If a frame has evaluated its arguments
+and called its function already, EVALD is t and ARGS is a list of
+values.  FLAGS is a plist of properties of the current frame:
+currently, the only supported property is :debug-on-exit.
+If BASE is non-nil, it should be a function and iteration will start
+from its nearest activation frame.
+`mapbacktrace' always returns nil.  */)
+     (Lisp_Object function, Lisp_Object base)
+{
+  union specbinding *pdl = get_backtrace_starting_at (base);
+
+  while (backtrace_p (pdl))
+    {
+      Lisp_Object flags = Qnil;
+      if (backtrace_debug_on_exit (pdl))
+        {
+          flags = Fcons (QCdebug_on_exit, Fcons (Qt, Qnil));
+        }
+
+      if (backtrace_nargs (pdl) == UNEVALLED)
+        {
+          call4 (function, Qnil, backtrace_function (pdl), *backtrace_args (pdl), flags);
+        }
+      else
+        {
+          Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
+          call4 (function, Qt, backtrace_function (pdl), tem, flags);
+        }
+      pdl = backtrace_next (pdl);
+    }
+
+  return Qnil;
+}
+
 DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
        doc: /* Print a trace of Lisp function calls currently active.
 Output stream used is value of `standard-output'.  */)
@@ -3470,18 +3524,10 @@ Output stream used is value of `standard-output'.  */)
 static union specbinding *
 get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
 {
-  union specbinding *pdl = backtrace_top ();
   register EMACS_INT i;
 
   CHECK_NATNUM (nframes);
-
-  if (!NILP (base))
-    { /* Skip up to `base'.  */
-      base = Findirect_function (base, Qt);
-      while (backtrace_p (pdl)
-	     && !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
-	pdl = backtrace_next (pdl);
-    }
+  union specbinding *pdl = get_backtrace_starting_at (base);
 
   /* Find the frame requested.  */
   for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--)
@@ -3974,6 +4020,8 @@ alist of active lexical bindings.  */);
   defsubr (&Sfetch_bytecode);
   defsubr (&Sbacktrace_debug);
   defsubr (&Sbacktrace);
+  DEFSYM (QCdebug_on_exit, ":debug-on-exit");
+  defsubr (&Smapbacktrace);
   defsubr (&Sbacktrace_frame);
   defsubr (&Sbacktrace_eval);
   defsubr (&Sbacktrace__locals);
-- 
2.7.4


[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 819 bytes --]