From 7bc009933e8926983e1f6676290a736b3e00575a Mon Sep 17 00:00:00 2001 From: Tom Tromey Date: Fri, 11 Sep 2009 20:05:55 +0200 Subject: [PATCH] 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)) --- src/data.c | 70 +++++++++++++++++++++++++++++++++++++++++++++++++++--- src/eval.c | 15 +++++++++--- src/lisp.h | 3 +++ 3 files changed, 82 insertions(+), 6 deletions(-) diff --git a/src/data.c b/src/data.c index 99408ab07b3..8d1ca2b4287 100644 --- a/src/data.c +++ b/src/data.c @@ -53,7 +53,7 @@ along with GNU Emacs. If not, see . */ 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 e0ab399caa3..3a8c242ade3 100644 --- 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 f412d97cd6b..32ec9cc548b 100644 --- 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; -- 2.39.2