master b8460fcb8c: Rewrite thread context switch code (bug#48990)

[Stefan Monnier]

branch: master
commit b8460fcb8c320ea6d7449f37f07502d10eb74cd5
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    Rewrite thread context switch code (bug#48990)
    
    Make the context switch code handle buffer-local variables more
    correctly by reusing the code originally written for `backtrace-eval`.
    This has the side benefit of making the `saved_value` field unused.
    
    * src/lisp.h (enum specbind_tag): Remove `saved_value` field.
    (rebind_for_thread_switch, unbind_for_thread_switch): Delete decls.
    (specpdl_unrewind): Declare function.
    
    * src/eval.c (specpdl_saved_value): Delete function.
    (specbind): Delete the code related to `saved_value`, and consolidate
    common code between the different branches.
    (rebind_for_thread_switch, -unbind_for_thread_switch): Move to `thread.c`.
    (specpdl_unrewind): New function, extracted from `backtrace_eval_unrewind`.
    Use `SET_INTERNAL_THREAD_SWITCH`.  Skip the buffer & excursion unwinds
    depending on new arg `vars_only`.
    (backtrace_eval_unrewind): Use it.
    (mark_specpdl): Don't mark `saved_value`.
    
    * src/thread.c (rebind_for_thread_switch, unbind_for_thread_switch):
    Move from `eval.c` and rewrite using `specpdl_unrewind`.
    
    * test/src/thread-tests.el (threads-test-bug48990): New test.
    
    * test/Makefile.in (test_template): Add a + as suggested by make:
    "warning: jobserver unavailable: using -j1.  Add '+' to parent make rule".
---
 src/eval.c               | 89 ++++++++++++++++--------------------------------
 src/lisp.h               |  6 +---
 src/thread.c             | 16 +++++++++
 test/Makefile.in         |  2 +-
 test/src/thread-tests.el | 25 ++++++++++++++
 5 files changed, 72 insertions(+), 66 deletions(-)

diff --git a/src/eval.c b/src/eval.c
index d1c45fca56..6bed7c4a89 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -103,13 +103,6 @@ specpdl_where (union specbinding *pdl)
   return pdl->let.where;
 }
 
-static Lisp_Object
-specpdl_saved_value (union specbinding *pdl)
-{
-  eassert (pdl->kind >= SPECPDL_LET);
-  return pdl->let.saved_value;
-}
-
 static Lisp_Object
 specpdl_arg (union specbinding *pdl)
 {
@@ -3589,9 +3582,6 @@ specbind (Lisp_Object symbol, Lisp_Object value)
       specpdl_ptr->let.kind = SPECPDL_LET;
       specpdl_ptr->let.symbol = symbol;
       specpdl_ptr->let.old_value = SYMBOL_VAL (sym);
-      specpdl_ptr->let.saved_value = Qnil;
-      grow_specpdl ();
-      do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND);
       break;
     case SYMBOL_LOCALIZED:
     case SYMBOL_FORWARDED:
@@ -3601,7 +3591,6 @@ specbind (Lisp_Object symbol, Lisp_Object value)
        specpdl_ptr->let.symbol = symbol;
        specpdl_ptr->let.old_value = ovalue;
        specpdl_ptr->let.where = Fcurrent_buffer ();
-       specpdl_ptr->let.saved_value = Qnil;
 
        eassert (sym->u.s.redirect != SYMBOL_LOCALIZED
                 || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
@@ -3619,22 +3608,17 @@ specbind (Lisp_Object symbol, Lisp_Object value)
               having their own value.  This is consistent with what
               happens with other buffer-local variables.  */
            if (NILP (Flocal_variable_p (symbol, Qnil)))
-             {
-               specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
-               grow_specpdl ();
-                do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND);
-               return;
-             }
+             specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
          }
        else
          specpdl_ptr->let.kind = SPECPDL_LET;
 
-       grow_specpdl ();
-        do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND);
        break;
       }
     default: emacs_abort ();
     }
+  grow_specpdl ();
+  do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND);
 }
 
 /* Push unwind-protect entries of various types.  */
@@ -3710,24 +3694,6 @@ record_unwind_protect_module (enum specbind_tag kind, 
void *ptr)
   grow_specpdl ();
 }
 
-void
-rebind_for_thread_switch (void)
-{
-  union specbinding *bind;
-
-  for (bind = specpdl; bind != specpdl_ptr; ++bind)
-    {
-      if (bind->kind >= SPECPDL_LET)
-       {
-         Lisp_Object value = specpdl_saved_value (bind);
-         Lisp_Object sym = specpdl_symbol (bind);
-         bind->let.saved_value = Qnil;
-          do_specbind (XSYMBOL (sym), bind, value,
-                       SET_INTERNAL_THREAD_SWITCH);
-       }
-    }
-}
-
 static void
 do_one_unbind (union specbinding *this_binding, bool unwinding,
                enum Set_Internal_Bind bindflag)
@@ -3884,22 +3850,6 @@ unbind_to (specpdl_ref count, Lisp_Object value)
   return value;
 }
 
-void
-unbind_for_thread_switch (struct thread_state *thr)
-{
-  union specbinding *bind;
-
-  for (bind = thr->m_specpdl_ptr; bind > thr->m_specpdl;)
-    {
-      if ((--bind)->kind >= SPECPDL_LET)
-       {
-         Lisp_Object sym = specpdl_symbol (bind);
-         bind->let.saved_value = find_symbol_value (sym);
-          do_one_unbind (bind, false, SET_INTERNAL_THREAD_SWITCH);
-       }
-    }
-}
-
 DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
        doc: /* Return non-nil if SYMBOL's global binding has been declared 
special.
 A special variable is one that will be bound dynamically, even in a
@@ -4055,11 +4005,13 @@ or a lambda expression for macro calls.  */)
    value and the old value stored in the specpdl), kind of like the inplace
    pointer-reversal trick.  As it turns out, the rewind does the same as the
    unwind, except it starts from the other end of the specpdl stack, so we use
-   the same function for both unwind and rewind.  */
-static void
-backtrace_eval_unrewind (int distance)
+   the same function for both unwind and rewind.
+   This same code is used when switching threads, except in that case
+   we unwind/rewind the whole specpdl of the threads.  */
+void
+specpdl_unrewind (union specbinding *pdl, int distance, bool vars_only)
 {
-  union specbinding *tmp = specpdl_ptr;
+  union specbinding *tmp = pdl;
   int step = -1;
   if (distance < 0)
     { /* It's a rewind rather than unwind.  */
@@ -4077,6 +4029,8 @@ backtrace_eval_unrewind (int distance)
             unwind_protect, but the problem is that we don't know how to
             rewind them afterwards.  */
        case SPECPDL_UNWIND:
+         if (vars_only)
+           break;
          if (tmp->unwind.func == set_buffer_if_live)
            {
              Lisp_Object oldarg = tmp->unwind.arg;
@@ -4085,6 +4039,8 @@ backtrace_eval_unrewind (int distance)
            }
          break;
        case SPECPDL_UNWIND_EXCURSION:
+         if (vars_only)
+           break;
          {
            Lisp_Object marker = tmp->unwind_excursion.marker;
            Lisp_Object window = tmp->unwind_excursion.window;
@@ -4125,7 +4081,7 @@ backtrace_eval_unrewind (int distance)
            Lisp_Object sym = specpdl_symbol (tmp);
            Lisp_Object old_value = specpdl_old_value (tmp);
            set_specpdl_old_value (tmp, default_value (sym));
-           Fset_default (sym, old_value);
+           set_default_internal (sym, old_value, SET_INTERNAL_THREAD_SWITCH);
          }
          break;
        case SPECPDL_LET_LOCAL:
@@ -4141,14 +4097,28 @@ backtrace_eval_unrewind (int distance)
              {
                set_specpdl_old_value
                  (tmp, buffer_local_value (symbol, where));
-                set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND);
+                set_internal (symbol, old_value, where,
+                              SET_INTERNAL_THREAD_SWITCH);
              }
+           else
+             /* FIXME: If the var is not local any more, we failed
+                 to swap the old and new values.  As long as the var remains
+                 non-local, this is fine, but if it ever reverts to being
+                 local we may end up using this entry "in the wrong
+                 direction".  */
+             ;
          }
          break;
        }
     }
 }
 
+static void
+backtrace_eval_unrewind (int distance)
+{
+  specpdl_unrewind (specpdl_ptr, distance, false);
+}
+
 DEFUN ("backtrace-eval", Fbacktrace_eval, Sbacktrace_eval, 2, 3, NULL,
        doc: /* Evaluate EXP in the context of some activation frame.
 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. 
 */)
@@ -4302,7 +4272,6 @@ mark_specpdl (union specbinding *first, union specbinding 
*ptr)
        case SPECPDL_LET:
          mark_object (specpdl_symbol (pdl));
          mark_object (specpdl_old_value (pdl));
-         mark_object (specpdl_saved_value (pdl));
          break;
 
        case SPECPDL_UNWIND_PTR:
diff --git a/src/lisp.h b/src/lisp.h
index f27c2ad2dd..19788ef07c 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3337,9 +3337,6 @@ union specbinding
       ENUM_BF (specbind_tag) kind : CHAR_BIT;
       /* `where' is not used in the case of SPECPDL_LET.  */
       Lisp_Object symbol, old_value, where;
-      /* Normally this is unused; but it is set to the symbol's
-        current value when a thread is swapped out.  */
-      Lisp_Object saved_value;
     } let;
     struct {
       ENUM_BF (specbind_tag) kind : CHAR_BIT;
@@ -4453,8 +4450,7 @@ extern void set_unwind_protect (specpdl_ref, void (*) 
(Lisp_Object),
                                Lisp_Object);
 extern void set_unwind_protect_ptr (specpdl_ref, void (*) (void *), void *);
 extern Lisp_Object unbind_to (specpdl_ref, Lisp_Object);
-extern void rebind_for_thread_switch (void);
-extern void unbind_for_thread_switch (struct thread_state *);
+void specpdl_unrewind (union specbinding *pdl, int distance, bool vars_only);
 extern AVOID error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
 extern AVOID verror (const char *, va_list)
   ATTRIBUTE_FORMAT_PRINTF (1, 0);
diff --git a/src/thread.c b/src/thread.c
index 8a6a2de18b..4c98d590b7 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -83,6 +83,22 @@ release_global_lock (void)
   sys_mutex_unlock (&global_lock);
 }
 
+static void
+rebind_for_thread_switch (void)
+{
+  ptrdiff_t distance
+    = current_thread->m_specpdl_ptr - current_thread->m_specpdl;
+  specpdl_unrewind (specpdl_ptr, -distance, true);
+}
+
+static void
+unbind_for_thread_switch (struct thread_state *thr)
+{
+  ptrdiff_t distance = thr->m_specpdl_ptr - thr->m_specpdl;
+  specpdl_unrewind (thr->m_specpdl_ptr, distance, true);
+}
+
+
 /* You must call this after acquiring the global lock.
    acquire_global_lock does it for you.  */
 static void
diff --git a/test/Makefile.in b/test/Makefile.in
index 9ad994e110..bc315ac4b3 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -243,7 +243,7 @@ define test_template
   .PHONY: $(1) $(notdir $(1))
   $(1):
        @test ! -f $(1).log || mv $(1).log $(1).log~
-       @$(MAKE) $(1).log WRITE_LOG=
+       +@$(MAKE) $(1).log WRITE_LOG=
   $(notdir $(1)): $(1)
 endef
 
diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el
index b7ab31120a..75d67140a9 100644
--- a/test/src/thread-tests.el
+++ b/test/src/thread-tests.el
@@ -393,4 +393,29 @@
   (let ((th (make-thread 'ignore)))
     (should-not (equal th main-thread))))
 
+(defvar threads-test--var 'global)
+
+(ert-deftest threads-test-bug48990 ()
+  (skip-unless (fboundp 'make-thread))
+  (let ((buf1 (generate-new-buffer " thread-test"))
+        (buf2 (generate-new-buffer " thread-test")))
+    (with-current-buffer buf1
+      (setq-local threads-test--var 'local1))
+    (with-current-buffer buf2
+      (setq-local threads-test--var 'local2))
+    (let ((seen nil))
+      (with-current-buffer buf1
+        (should (eq threads-test--var 'local1))
+        (make-thread (lambda () (setq seen threads-test--var))))
+      (with-current-buffer buf2
+        (should (eq threads-test--var 'local2))
+        (let ((threads-test--var 'let2))
+          (should (eq threads-test--var 'let2))
+          (while (not seen)
+            (thread-yield))
+          (should (eq threads-test--var 'let2))
+          (should (eq seen 'local1)))
+        (should (eq threads-test--var 'local2)))
+      (should (eq threads-test--var 'global)))))
+
 ;;; thread-tests.el ends here