First working draft of thread-local binding.

At least 2 of the 9 kinds of variable bindings should work ok --
defvaralias variables and ordinary variables.
All other kinds will exhibit weird behavior.
A simple program that works:

   (defvar zz t)
   (defvar buffer-a (get-buffer-create "zardoz"))

   (defun tha ()
     (dolist (v '("A" "B" "C" "D"))
	(message "thread a: %s" v)
	(yield))
     (setq zz nil))

   (defun thb ()
     (dolist (v '("E" "F" "G" "H" "I"))
	(message "thread b: %s" v)
	(yield)
	))

   (with-current-buffer buffer-a
     (run-in-thread 'tha))
   (thb)

   (while zz
     (yield))

diff --git a/src/data.c b/src/data.c
index 99408ab07b3c50d9359c784b646004b6dfec05ca..8d1ca2b42872e59f2045835a87dd5f64b7289937 100644 (file)
--- a/src/data.c
+++ b/src/data.c
@@ -53,7 +53,7 @@ along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
 extern double atof ();
 #endif /* !atof */
 
-Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
+Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound, Qthread_local_mark;
 Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
 Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
@@ -818,12 +818,67 @@ find_variable_location (Lisp_Object *root)
   if (THREADLOCALP (*root))
     {
       struct Lisp_ThreadLocal *thr = XTHREADLOCAL (*root);
+      Lisp_Object cons = assq_no_quit (get_current_thread (),
+                                      thr->thread_alist);
+      if (!EQ (cons, Qnil))
+       return &XCDR_AS_LVALUE (cons);
       return &thr->global;
     }
 
   return root;
 }
 
+Lisp_Object
+ensure_thread_local (Lisp_Object *root)
+{
+  Lisp_Object cons;
+
+  if (THREADLOCALP (*root))
+    cons = assq_no_quit (get_current_thread (),
+                        XTHREADLOCAL (*root)->thread_alist);
+  else
+    {
+      Lisp_Object newval;
+      newval = allocate_misc ();
+      XMISCTYPE (newval) = Lisp_Misc_ThreadLocal;
+      XTHREADLOCAL (newval)->global = *root;
+      XTHREADLOCAL (newval)->thread_alist = Qnil;
+      *root = newval;
+      cons = Qnil;
+    }
+
+  if (NILP (cons))
+    {
+      struct Lisp_ThreadLocal *local = XTHREADLOCAL (*root);
+      cons = Fcons (get_current_thread (), Qthread_local_mark);
+      local->thread_alist = Fcons (cons, local->thread_alist);
+    }
+
+  return cons;
+}
+
+void
+remove_thread_local (Lisp_Object *root)
+{
+  if (THREADLOCALP (*root))
+    {
+      Lisp_Object iter, thr = get_current_thread (), prior = Qnil;
+      struct Lisp_ThreadLocal *local = XTHREADLOCAL (*root);
+      for (iter = local->thread_alist; !NILP (iter); iter = XCDR (iter))
+       {
+         if (EQ (XCAR (XCAR (iter)), thr))
+           {
+             if (NILP (prior))
+               local->thread_alist = XCDR (iter);
+             else
+               XSETCDR (prior, XCDR (iter));
+             break;
+           }
+         prior = iter;
+       }
+    }
+}
+
 /* Return the symbol holding SYMBOL's value.  Signal
    `cyclic-variable-indirection' if SYMBOL's chain of variable
    indirections contains a loop.  */
@@ -879,7 +934,7 @@ variable chain of symbols.  */)
 
 Lisp_Object
 do_symval_forwarding (valcontents)
-     register Lisp_Object valcontents;
+     Lisp_Object valcontents;
 {
   register Lisp_Object val;
   if (MISCP (valcontents))
@@ -913,6 +968,9 @@ do_symval_forwarding (valcontents)
            don't think anything will break.  --lorentey  */
        return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
                                + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
+
+      case Lisp_Misc_ThreadLocal:
+       return *find_variable_location (&valcontents);
       }
   return valcontents;
 }
@@ -951,7 +1009,7 @@ store_symval_forwarding (symbol, valcontents, newval, buf)
          break;
 
        case Lisp_Misc_Objfwd:
-         *XOBJFWD (valcontents)->objvar = newval;
+         *find_variable_location (XOBJFWD (valcontents)->objvar) = newval;
 
          /* If this variable is a default for something stored
             in the buffer itself, such as default-fill-column,
@@ -1019,6 +1077,8 @@ store_symval_forwarding (symbol, valcontents, newval, buf)
       valcontents = SYMBOL_VALUE (symbol);
       if (BUFFER_LOCAL_VALUEP (valcontents))
        XBUFFER_LOCAL_VALUE (valcontents)->realvalue = newval;
+      else if (THREADLOCALP (valcontents))
+       *find_variable_location (&XSYMBOL (symbol)->value) = newval;
       else
        SET_SYMBOL_VALUE (symbol, newval);
     }
@@ -3166,6 +3226,9 @@ syms_of_data ()
   Qbool_vector = intern_c_string ("bool-vector");
   Qhash_table = intern_c_string ("hash-table");
 
+  Qthread_local_mark = Fmake_symbol (make_pure_string ("thread-local-mark",
+                                                      17, 17, 0));
+
   DEFSYM (Qfont_spec, "font-spec");
   DEFSYM (Qfont_entity, "font-entity");
   DEFSYM (Qfont_object, "font-object");
@@ -3190,6 +3253,7 @@ syms_of_data ()
   staticpro (&Qchar_table);
   staticpro (&Qbool_vector);
   staticpro (&Qhash_table);
+  staticpro (&Qthread_local_mark);
 
   defsubr (&Sindirect_variable);
   defsubr (&Sinteractive_form);

diff --git a/src/eval.c b/src/eval.c
index e0ab399caa3b711151011949ab247e7d95e60345..3a8c242ade3952138efc553e33168828d16e6f58 100644 (file)
--- a/src/eval.c
+++ b/src/eval.c
@@ -3251,11 +3251,15 @@ specbind (symbol, value)
   valcontents = SYMBOL_VALUE (symbol);
   if (!MISCP (valcontents) && !SYMBOL_CONSTANT_P (symbol))
     {
+      Lisp_Object cons
+       = ensure_thread_local (&indirect_variable (XSYMBOL (symbol))->value);
       specpdl_ptr->symbol = symbol;
-      specpdl_ptr->old_value = valcontents;
+      /* We know VALCONTENTS is equivalent to the CDR, but we save the
+        CDR in case it is the thread-local mark.  */
+      specpdl_ptr->old_value = XCDR (cons);
       specpdl_ptr->func = NULL;
       ++specpdl_ptr;
-      SET_SYMBOL_VALUE (symbol, value);
+      XSETCDR (cons, value);
     }
   else
     {
@@ -3383,7 +3387,12 @@ unbind_to (count, value)
          if (!MISCP (SYMBOL_VALUE (this_binding.symbol)))
            SET_SYMBOL_VALUE (this_binding.symbol, this_binding.old_value);
          else
-           set_internal (this_binding.symbol, this_binding.old_value, 0, 1);
+           {
+             if (EQ (this_binding.old_value, Qthread_local_mark))
+               remove_thread_local (&indirect_variable (XSYMBOL (this_binding.symbol))->value);
+             else
+               set_internal (this_binding.symbol, this_binding.old_value, 0, 1);
+           }
        }
     }
 

diff --git a/src/lisp.h b/src/lisp.h
index f412d97cd6bc9429eb80b725c2ab401264b9b77e..32ec9cc548b00821954223eaa353b50c24f4bbcb 100644 (file)
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2343,6 +2343,9 @@ EXFUN (Fmake_variable_buffer_local, 1);
 
 extern struct Lisp_Symbol *indirect_variable (struct Lisp_Symbol *);
 extern Lisp_Object *find_variable_location (Lisp_Object *);
+extern Lisp_Object ensure_thread_local (Lisp_Object *);
+extern void remove_thread_local P_ ((Lisp_Object *));
+extern Lisp_Object Qthread_local_mark;
 extern Lisp_Object long_to_cons P_ ((unsigned long));
 extern unsigned long cons_to_long P_ ((Lisp_Object));
 extern void args_out_of_range P_ ((Lisp_Object, Lisp_Object)) NO_RETURN;