[PATCH] Add backtrace support for dynamic modules.

[Philipp Stephani]

Whenever Emacs would jump to the handler installed at the module code
boundary, record the part of the backtrace that’s inside the module
code in a Lisp object.  After returning from the enclosing module
function, restore that parts of the backtrace so that it looks as if
the frames from the original nonlocal exit were still active.

* lisp.h (struct handler): Add field for the module environment that
should hold the backtrace.

* eval.c (push_handler_nosignal): Initialize new field.
(unwind_to_catch): Save module backtrace if this handler is for a
module entry point.
(save_backtrace): New function to save a backtrace in a Lisp object.
(restore_backtrace): New function to restore a backtrace saved by
‘save_backtrace’.

* emacs-module.c (struct emacs_env_private): Add fields for specpdl
index and backtrace.
(initialize_environment): Initialize them.
(mark_modules): Mark saved backtrace.
(MODULE_HANDLE_NONLOCAL_EXIT): Set module environment field in
handler.
(module_signal_or_throw): Restore potential backtrace.
(module_return_nil, module_save_backtrace)
(module_save_backtrace_1): New functions to save the backtrace frames.
(module_restore_backtrace): New function to restore the saved
backtrace frames.

* test/data/emacs-module/mod-test.c (Fmod_test_funcall): New test
function.
(emacs_module_init): Define it.

* test/src/emacs-module-tests.el (mod-test-error): New test error
symbol.
(module-backtrace, module-backtrace-reentrant): New unit tests.
---
 src/emacs-module.c                |  51 ++++++++++++++
 src/eval.c                        |  75 +++++++++++++++++++++
 src/lisp.h                        |  12 ++++
 test/data/emacs-module/mod-test.c |  11 +++
 test/src/emacs-module-tests.el    | 107 ++++++++++++++++++++++++++++++
 5 files changed, 256 insertions(+)

diff --git a/src/emacs-module.c b/src/emacs-module.c
index b905094255..77ea4e256e 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -187,6 +187,14 @@ struct emacs_env_private
   struct emacs_value_tag non_local_exit_symbol, non_local_exit_data;
 
   struct emacs_value_storage storage;
+
+  /* The value of SPECPDL_INDEX () when this environment was
+     initialized.  */
+  ptrdiff_t specpdl_index;
+
+  /* Backtrace frames returned by `save_backtrace', or nil if there is
+     no saved backtrace.  */
+  Lisp_Object saved_backtrace;
 };
 
 /* The private parts of an `emacs_runtime' object contain the initial
@@ -223,6 +231,7 @@ static void module_reset_handlerlist (struct handler **);
 static bool value_storage_contains_p (const struct emacs_value_storage *,
                                       emacs_value, ptrdiff_t *);
 static Lisp_Object module_encode (Lisp_Object);
+static void module_restore_backtrace (struct emacs_env_private *);
 
 static bool module_assertions = false;
 
@@ -272,6 +281,7 @@ static bool module_assertions = false;
       module_out_of_memory (env);                                      \
       return retval;                                                   \
     }                                                                  \
+  internal_handler->module_env = env->private_members;                  \
   struct handler *internal_cleanup                                      \
     __attribute__ ((cleanup (module_reset_handlerlist)))                \
     = internal_handler;                                                 \
@@ -810,9 +820,11 @@ module_signal_or_throw (struct emacs_env_private *env)
     case emacs_funcall_exit_return:
       return;
     case emacs_funcall_exit_signal:
+      module_restore_backtrace (env);
       xsignal (value_to_lisp (&env->non_local_exit_symbol),
                value_to_lisp (&env->non_local_exit_data));
     case emacs_funcall_exit_throw:
+      module_restore_backtrace (env);
       Fthrow (value_to_lisp (&env->non_local_exit_symbol),
               value_to_lisp (&env->non_local_exit_data));
     default:
@@ -1151,6 +1163,7 @@ mark_modules (void)
           frame = frame->next)
         for (int i = 0; i < frame->offset; ++i)
           mark_object (frame->objects[i].v);
+      mark_object (priv->saved_backtrace);
     }
 }
 
@@ -1171,6 +1184,8 @@ initialize_environment (emacs_env *env, struct 
emacs_env_private *priv)
 
   priv->pending_non_local_exit = emacs_funcall_exit_return;
   initialize_storage (&priv->storage);
+  priv->specpdl_index = SPECPDL_INDEX ();
+  priv->saved_backtrace = Qnil;
   env->size = sizeof *env;
   env->private_members = priv;
   env->make_global_ref = module_make_global_ref;
@@ -1312,6 +1327,42 @@ module_abort (const char *format, ...)
   emacs_abort ();
 }
 
+static Lisp_Object
+module_return_nil (enum nonlocal_exit type, Lisp_Object data)
+{
+  return Qnil;
+}
+
+static Lisp_Object
+module_save_backtrace_1 (void *arg)
+{
+  ptrdiff_t from = *(ptrdiff_t *) arg;
+  return save_backtrace (from);
+}
+
+/* Save the backtrace between the current activation frame and the
+   activation frame that was active when this module was initialized.
+   This function must not exit nonlocally since it's called from
+   `signal' and `throw'.  Otherwise failing to save the backtrace
+   would result in an infinite loop and a C stack overflow.  */
+
+void
+module_save_backtrace (struct emacs_env_private *env) {
+  env->saved_backtrace
+    = internal_catch_all (module_save_backtrace_1, &env->specpdl_index,
+                          module_return_nil);
+}
+
+/* Restore the backtrace frames stored in ENV.  We can allow this to
+   exit nonlocally.  */
+
+static void
+module_restore_backtrace (struct emacs_env_private *env)
+{
+  eassert (SPECPDL_INDEX () >= env->specpdl_index);
+  restore_backtrace (env->saved_backtrace);
+}
+
 
 /* Segment initializer.  */
 
diff --git a/src/eval.c b/src/eval.c
index 3fd9a40a3a..d30cb6016a 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1147,6 +1147,12 @@ unwind_to_catch (struct handler *catch, enum 
nonlocal_exit type,
   catch->nonlocal_exit = type;
   catch->val = value;
 
+#ifdef HAVE_MODULES
+  if (catch->module_env)
+    /* Save backtrace frame to be recovered later.  */
+    module_save_backtrace (catch->module_env);
+#endif
+
   /* Restore certain special C variables.  */
   set_poll_suppress_count (catch->poll_suppress_count);
   unblock_input_to (catch->interrupt_input_blocked);
@@ -1488,6 +1494,9 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum 
handlertype handlertype)
   c->type = handlertype;
   c->tag_or_ch = tag_ch_val;
   c->val = Qnil;
+#ifdef HAVE_MODULES
+  c->module_env = NULL;
+#endif
   c->next = handlerlist;
   c->f_lisp_eval_depth = lisp_eval_depth;
   c->pdlcount = SPECPDL_INDEX ();
@@ -3933,6 +3942,72 @@ NFRAMES and BASE specify the activation frame to use, as 
in `backtrace-frame'.
   return result;
 }
 
+/* Return a list of backtrace frames from the top of the stack until
+   specpdl index FROM.  The deepest frame close to FROM is the first
+   element of the return value.  Each frame is a triple
+   (EVALD FUNC ARGS).  EVALD, FUNC, and ARGS have the same meaning as
+   for `mapbacktrace', except that ARGS is a vector instead of a
+   list.  */
+
+Lisp_Object
+save_backtrace (ptrdiff_t from)
+{
+  eassert (from >= 0);
+  union specbinding *pdl = backtrace_top ();
+  Lisp_Object result = Qnil;
+  /* We can't just save FROM because Emacs will overwrite the specpdl
+     vector until we call `restore_backtrace'.  */
+  while (backtrace_p (pdl) && pdl - specpdl >= from)
+    {
+      ptrdiff_t i = pdl - specpdl;
+      eassert (i >= 0);
+      ptrdiff_t nargs = backtrace_nargs (pdl);
+      eassert (nargs == UNEVALLED || nargs >= 0);
+      bool evald = nargs != UNEVALLED;
+      Lisp_Object func = backtrace_function (pdl);
+      /* If EVALD is nil, there's always exactly one argument, see
+         `eval_sub' and `backtrace_frame_apply'.  We use a vector
+         because `record_in_backtrace' requires a contiguous array.
+         We have to copy the contents of the argument array because
+         they refer to automatic variables, which will be out of scope
+         once we call `restore_backtrace'.  */
+      Lisp_Object args = Fvector (evald ? nargs : 1, backtrace_args (pdl));
+      Lisp_Object frame = list3 (evald ? Qt : Qnil, func, args);
+      result = Fcons (frame, result);
+      /* Beware! PDL is no longer valid here because the code above
+         might have caused grow_specpdl to reallocate pdlvec.  We must
+         use the saved index, cf. Bug#27258.  */
+      pdl = backtrace_next (&specpdl[i]);
+    }
+  /* Not calling `reverse' here allows the return value to be used by
+     `restore_backtrace' as-is.  */
+  return result;
+}
+
+/* Restore backtrace elements in SAVED.  SAVED must be a list of
+   backtrace frames created by `save_backtrace'.  This function
+   doesn't validate SAVED.  */
+
+void
+restore_backtrace (Lisp_Object saved)
+{
+  for (Lisp_Object tail = saved; CONSP (tail); tail = XCDR (tail))
+    {
+      Lisp_Object frame = XCAR (tail);
+      bool evald = !NILP (XCAR (frame));
+      frame = XCDR (frame);
+      Lisp_Object func = XCAR (frame);
+      frame = XCDR (frame);
+      Lisp_Object args = XCAR (frame);
+      eassert (NILP (XCDR (frame)));
+      eassert (evald || ASIZE (args) == 1);
+      ptrdiff_t nargs = evald ? ASIZE (args) : UNEVALLED;
+      /* Because `record_in_backtrace' doesn't copy anything, we can
+         only refer to heap-allocated objects here.  */
+      record_in_backtrace (func, aref_addr (args, 0), nargs);
+    }
+}
+
 
 void
 mark_specpdl (union specbinding *first, union specbinding *ptr)
diff --git a/src/lisp.h b/src/lisp.h
index ca833476c0..90e21693a8 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3262,6 +3262,15 @@ struct handler
   enum nonlocal_exit nonlocal_exit;
   Lisp_Object val;
 
+#ifdef HAVE_MODULES
+  /* If this handler was installed at a module boundary (see
+     MODULE_FUNCTION_BEGIN in emacs-module.c), module_env is set to
+     the module environment that installed the handler, and `signal'
+     and `throw' will save a backtrace to be recovered later.
+     Otherwise module_env is NULL.  */
+  struct emacs_env_private *module_env;
+#endif
+
   struct handler *next;
   struct handler *nextfree;
 
@@ -4144,6 +4153,8 @@ extern void mark_specpdl (union specbinding *first, union 
specbinding *ptr);
 extern void get_backtrace (Lisp_Object array);
 Lisp_Object backtrace_top_function (void);
 extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
+extern Lisp_Object save_backtrace (ptrdiff_t);
+extern void restore_backtrace (Lisp_Object);
 
 /* Defined in unexmacosx.c.  */
 #if defined DARWIN_OS && defined HAVE_UNEXEC
@@ -4187,6 +4198,7 @@ extern module_funcptr module_function_address
   (struct Lisp_Module_Function const *);
 extern void mark_modules (void);
 extern void init_module_assertions (bool);
+extern void module_save_backtrace (struct emacs_env_private *);
 extern void syms_of_module (void);
 #endif
 
diff --git a/test/data/emacs-module/mod-test.c 
b/test/data/emacs-module/mod-test.c
index b7007bd80f..4d883ddeb7 100644
--- a/test/data/emacs-module/mod-test.c
+++ b/test/data/emacs-module/mod-test.c
@@ -157,6 +157,16 @@ Fmod_test_non_local_exit_funcall (emacs_env *env, 
ptrdiff_t nargs,
 }
 
 
+/* Just call the argument function without catching anything.  */
+static emacs_value
+Fmod_test_funcall (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
+                   void *data)
+{
+  assert (nargs == 1);
+  return env->funcall (env, args[0], 0, NULL);
+}
+
+
 /* Return a global reference.  */
 static emacs_value
 Fmod_test_globref_make (emacs_env *env, ptrdiff_t nargs, emacs_value args[],
@@ -473,6 +483,7 @@ emacs_module_init (struct emacs_runtime *ert)
   DEFUN ("mod-test-throw", Fmod_test_throw, 0, 0, NULL, NULL);
   DEFUN ("mod-test-non-local-exit-funcall", Fmod_test_non_local_exit_funcall,
         1, 1, NULL, NULL);
+  DEFUN ("mod-test-funcall", Fmod_test_funcall, 1, 1, NULL, NULL);
   DEFUN ("mod-test-globref-make", Fmod_test_globref_make, 0, 0, NULL, NULL);
   DEFUN ("mod-test-globref-free", Fmod_test_globref_free, 4, 4, NULL, NULL);
   DEFUN ("mod-test-string-a-to-b", Fmod_test_string_a_to_b, 1, 1, NULL, NULL);
diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index 173b63670f..b6109f0125 100644
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -40,6 +40,9 @@ mod-test-emacs
 (cl-defmethod emacs-module-tests--generic ((_ user-ptr))
   'user-ptr)
 
+(define-error 'mod-test-error
+  "Module test error")
+
 ;;
 ;; Basic tests.
 ;;
@@ -368,4 +371,108 @@ module--test-assertion
     (ert-info ((format "input: %d" input))
       (should (= (mod-test-double input) (* 2 input))))))
 
+(ert-deftest module-backtrace ()
+  "Check that backtraces are preserved across module calls."
+  (let* ((signal-args ())
+         (backtraces ())
+         (unwindings 0)
+         (err (should-error
+               ;; Bind `signal-hook-function' as tightly as possible
+               ;; to not interfere with ERT's error handling
+               ;; machinery.
+               (let ((signal-hook-function
+                      (lambda (&rest args)
+                        ;; Test that garbage collection doesn't
+                        ;; destroy the saved backtrace.
+                        (garbage-collect)
+                        (push args signal-args)
+                        (push (backtrace-frames) backtraces))))
+                 (mod-test-funcall (lambda ()
+                                     (unwind-protect
+                                         (signal 'mod-test-error '(17))
+                                       (cl-incf unwindings)))))
+               :type 'mod-test-error)))
+    (should (equal err '(mod-test-error 17)))
+    (should (eq unwindings 1))
+    ;; Emacs has called `signal' twice: once as part of the `lambda'
+    ;; form, a second time after returning from `mod-test-funcall'.
+    (should (equal signal-args '((mod-test-error (17))
+                                 (mod-test-error (17)))))
+    (should (eq (length backtraces) 2))
+    ;; Test that Emacs has correctly preserved the backtrace.
+    (should (equal (nth 0 backtraces) (nth 1 backtraces)))
+    ;; When analyzing the backtrace frames, we only care about
+    ;; function calls.  Other frames could be essentially arbitrary
+    ;; macro expansions.
+    (let ((backtrace (cl-remove nil (car backtraces) :key #'car :test #'eq)))
+      (should (equal (nth 0 backtrace) '(t backtrace-frames () nil)))
+      ;; Element 1 is the call to the `lambda' form bound to
+      ;; `signal-hook-function'.
+      (should (equal (nth 2 backtrace) '(t signal (mod-test-error (17)) nil)))
+      ;; Element 3 is the call to the `lambda' form in the argument to
+      ;; `mod-test-funcall'.
+      (cl-destructuring-bind (evald fun args flags) (nth 4 backtrace)
+        (should (equal evald t))
+        (should (equal fun 'mod-test-funcall))
+        (should (consp args))
+        (should-not flags)))))
+
+(ert-deftest module-backtrace-reentrant ()
+  "Check that backtraces are preserved even with reentrant module calls."
+  (let* ((signal-args ())
+         (backtraces ())
+         (unwindings 0)
+         (err (should-error
+               ;; Bind `signal-hook-function' as tightly as possible
+               ;; to not interfere with ERT's error handling
+               ;; machinery.
+               (let ((signal-hook-function
+                      (lambda (&rest args)
+                        ;; Test that garbage collection doesn't
+                        ;; destroy the saved backtrace.
+                        (garbage-collect)
+                        (push args signal-args)
+                        (push (backtrace-frames) backtraces))))
+                 (mod-test-funcall
+                  (lambda ()
+                    (mod-test-funcall
+                     (lambda ()
+                       (unwind-protect
+                           (signal 'mod-test-error '(17))
+                         (cl-incf unwindings)))))))
+               :type 'mod-test-error)))
+    (should (equal err '(mod-test-error 17)))
+    (should (eq unwindings 1))
+    ;; Emacs has called `signal' thrice: twice as part of the `lambda'
+    ;; forms, a third time after returning from `mod-test-funcall'.
+    (should (equal signal-args '((mod-test-error (17))
+                                 (mod-test-error (17))
+                                 (mod-test-error (17)))))
+    (should (eq (length backtraces) 3))
+    ;; Test that Emacs has correctly preserved the backtrace.
+    (should (equal (nth 0 backtraces) (nth 1 backtraces)))
+    (should (equal (nth 0 backtraces) (nth 2 backtraces)))
+    ;; When analyzing the backtrace frames, we only care about
+    ;; function calls.  Other frames could be essentially arbitrary
+    ;; macro expansions.
+    (let ((backtrace (cl-remove nil (car backtraces) :key #'car :test #'eq)))
+      (should (equal (nth 0 backtrace) '(t backtrace-frames () nil)))
+      ;; Element 1 is the call to the `lambda' form bound to
+      ;; `signal-hook-function'.
+      (should (equal (nth 2 backtrace) '(t signal (mod-test-error (17)) nil)))
+      ;; Element 3 is the call to the `lambda' form in the argument to
+      ;; `mod-test-funcall'.
+      (cl-destructuring-bind (evald fun args flags) (nth 4 backtrace)
+        (should (eq evald t))
+        (should (eq fun 'mod-test-funcall))
+        (should (consp args))
+        (should-not flags))
+      ;; Element 5 is the call to the `lambda' form in the argument to
+      ;; `mod-test-funcall'.
+      (cl-destructuring-bind (evald fun args flags) (nth 6 backtrace)
+        (should (eq evald t))
+        (should (eq fun 'mod-test-funcall))
+        (should (consp args))
+        (should-not flags)))))
+
 ;;; emacs-module-tests.el ends here
-- 
2.20.1 (Apple Git-117)