diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Makefile.in | 1 | ||||
| -rw-r--r-- | src/alloc.c | 89 | ||||
| -rw-r--r-- | src/buffer.c | 5 | ||||
| -rw-r--r-- | src/buffer.h | 4 | ||||
| -rw-r--r-- | src/bytecode.c | 13 | ||||
| -rw-r--r-- | src/data.c | 43 | ||||
| -rw-r--r-- | src/emacs.c | 18 | ||||
| -rw-r--r-- | src/eval.c | 252 | ||||
| -rw-r--r-- | src/lisp.h | 73 | ||||
| -rw-r--r-- | src/print.c | 36 | ||||
| -rw-r--r-- | src/process.c | 523 | ||||
| -rw-r--r-- | src/process.h | 5 | ||||
| -rw-r--r-- | src/regex.c | 10 | ||||
| -rw-r--r-- | src/regex.h | 4 | ||||
| -rw-r--r-- | src/search.c | 22 | ||||
| -rw-r--r-- | src/systhread.c | 131 | ||||
| -rw-r--r-- | src/systhread.h | 63 | ||||
| -rw-r--r-- | src/thread.c | 955 | ||||
| -rw-r--r-- | src/thread.h | 250 | ||||
| -rw-r--r-- | src/window.c | 8 |
20 files changed, 2114 insertions, 391 deletions
diff --git a/src/Makefile.in b/src/Makefile.in index 0556bae1ecd..86e5aca36ec 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -370,6 +370,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ region-cache.o sound.o atimer.o \ doprnt.o intervals.o textprop.o composite.o xml.o $(NOTIFY_OBJ) \ profiler.o \ + thread.o systhread.o \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) obj = $(base_obj) $(NS_OBJC_OBJ) diff --git a/src/alloc.c b/src/alloc.c index cce0fff4fd4..b5885bdb283 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -306,10 +306,6 @@ struct mem_node enum mem_type type; }; -/* Base address of stack. Set in main. */ - -Lisp_Object *stack_base; - /* Root of the tree describing allocated Lisp memory. */ static struct mem_node *mem_root; @@ -339,10 +335,6 @@ static struct mem_node *mem_find (void *); # define DEADP(x) 0 #endif -/* Recording what needs to be marked for gc. */ - -struct gcpro *gcprolist; - /* Addresses of staticpro'd variables. Initialize it to a nonzero value; otherwise some compilers put it into BSS. */ @@ -2826,6 +2818,13 @@ sweep_vectors (void) { ptrdiff_t total_bytes; + if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD)) + finalize_one_thread ((struct thread_state *) vector); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX)) + finalize_one_mutex ((struct Lisp_Mutex *) vector); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR)) + finalize_one_condvar ((struct Lisp_CondVar *) vector); + nbytes = vector_nbytes (vector); total_bytes = nbytes; next = ADVANCE (vector, nbytes); @@ -4627,8 +4626,27 @@ dump_zombies (void) would be necessary, each one starting with one byte more offset from the stack start. */ -static void -mark_stack (void) +void +mark_stack (char *bottom, char *end) +{ + /* This assumes that the stack is a contiguous region in memory. If + that's not the case, something has to be done here to iterate + over the stack segments. */ + mark_memory (bottom, end); + + /* Allow for marking a secondary stack, like the register stack on the + ia64. */ +#ifdef GC_MARK_SECONDARY_STACK + GC_MARK_SECONDARY_STACK (); +#endif + +#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS + check_gcpros (); +#endif +} + +void +flush_stack_call_func (void (*func) (void *arg), void *arg) { void *end; @@ -4645,7 +4663,7 @@ mark_stack (void) Lisp_Object o; sys_jmp_buf j; } j; - volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base; + volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom; #endif /* This trick flushes the register windows so that all the state of the process is contained in the stack. */ @@ -4684,20 +4702,8 @@ mark_stack (void) #endif /* not GC_SAVE_REGISTERS_ON_STACK */ #endif /* not HAVE___BUILTIN_UNWIND_INIT */ - /* This assumes that the stack is a contiguous region in memory. If - that's not the case, something has to be done here to iterate - over the stack segments. */ - mark_memory (stack_base, end); - - /* Allow for marking a secondary stack, like the register stack on the - ia64. */ -#ifdef GC_MARK_SECONDARY_STACK - GC_MARK_SECONDARY_STACK (); -#endif - -#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS - check_gcpros (); -#endif + current_thread->stack_top = end; + (*func) (arg); } #endif /* GC_MARK_STACK != 0 */ @@ -5250,7 +5256,7 @@ See Info node `(elisp)Garbage Collection'. */) for (i = 0; i < staticidx; i++) mark_object (*staticvec[i]); - mark_specpdl (); + mark_threads (); mark_terminals (); mark_kboards (); @@ -5258,39 +5264,12 @@ See Info node `(elisp)Garbage Collection'. */) xg_mark_data (); #endif -#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ - || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) - mark_stack (); -#else - { - register struct gcpro *tail; - for (tail = gcprolist; tail; tail = tail->next) - for (i = 0; i < tail->nvars; i++) - mark_object (tail->var[i]); - } - mark_byte_stack (); - { - struct catchtag *catch; - struct handler *handler; - - for (catch = catchlist; catch; catch = catch->next) - { - mark_object (catch->tag); - mark_object (catch->val); - } - for (handler = handlerlist; handler; handler = handler->next) - { - mark_object (handler->handler); - mark_object (handler->var); - } - } -#endif - #ifdef HAVE_WINDOW_SYSTEM mark_fringe_data (); #endif #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES + FIXME; mark_stack (); #endif @@ -5340,7 +5319,7 @@ See Info node `(elisp)Garbage Collection'. */) /* Clear the mark bits that we set in certain root slots. */ - unmark_byte_stack (); + unmark_threads (); VECTOR_UNMARK (&buffer_defaults); VECTOR_UNMARK (&buffer_local_symbols); diff --git a/src/buffer.c b/src/buffer.c index abebdf21135..e78962e1550 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -44,8 +44,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "keymap.h" #include "frame.h" -struct buffer *current_buffer; /* The current buffer. */ - /* First buffer in chain of all buffers (in reverse order of creation). Threaded through ->header.next.buffer. */ @@ -1728,6 +1726,9 @@ cleaning up all windows currently displaying the buffer to be killed. */) if (!BUFFER_LIVE_P (b)) return Qnil; + if (thread_check_current_buffer (b)) + return Qnil; + /* Query if the buffer is still modified. */ if (INTERACTIVE && !NILP (BVAR (b, filename)) && BUF_MODIFF (b) > BUF_SAVE_MODIFF (b)) diff --git a/src/buffer.h b/src/buffer.h index 276cca32e48..2b0b49dddad 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -1022,10 +1022,6 @@ extern struct buffer *all_buffers; #define FOR_EACH_BUFFER(b) \ for ((b) = all_buffers; (b); (b) = (b)->next) -/* This points to the current buffer. */ - -extern struct buffer *current_buffer; - /* This structure holds the default values of the buffer-local variables that have special slots in each buffer. The default value occupies the same slot in this structure diff --git a/src/bytecode.c b/src/bytecode.c index 4940fd5c182..9e5f4d1434f 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -329,19 +329,18 @@ struct byte_stack done. Signaling an error truncates the list analogous to gcprolist. */ -struct byte_stack *byte_stack_list; +/* struct byte_stack *byte_stack_list; */ /* Mark objects on byte_stack_list. Called during GC. */ #if BYTE_MARK_STACK void -mark_byte_stack (void) +mark_byte_stack (struct byte_stack *stack) { - struct byte_stack *stack; Lisp_Object *obj; - for (stack = byte_stack_list; stack; stack = stack->next) + for (; stack; stack = stack->next) { /* If STACK->top is null here, this means there's an opcode in Fbyte_code that wasn't expected to GC, but did. To find out @@ -365,11 +364,9 @@ mark_byte_stack (void) counters. Called when GC has completed. */ void -unmark_byte_stack (void) +unmark_byte_stack (struct byte_stack *stack) { - struct byte_stack *stack; - - for (stack = byte_stack_list; stack; stack = stack->next) + for (; stack; stack = stack->next) { if (stack->byte_string_start != SDATA (stack->byte_string)) { diff --git a/src/data.c b/src/data.c index fc66cea6497..c6cb1b43dd6 100644 --- a/src/data.c +++ b/src/data.c @@ -79,6 +79,7 @@ static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; static Lisp_Object Qsubrp, Qmany, Qunevalled; Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; static Lisp_Object Qdefun; +Lisp_Object Qthread, Qmutex, Qcondition_variable; Lisp_Object Qinteractive_form; static Lisp_Object Qdefalias_fset_function; @@ -198,6 +199,12 @@ for example, (type-of 1) returns `integer'. */) return Qfont_entity; if (FONT_OBJECT_P (object)) return Qfont_object; + if (THREADP (object)) + return Qthread; + if (MUTEXP (object)) + return Qmutex; + if (CONDVARP (object)) + return Qcondition_variable; return Qvector; case Lisp_Float: @@ -445,6 +452,36 @@ DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, return Qnil; } +DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0, + doc: /* Return t if OBJECT is a thread. */) + (Lisp_Object object) +{ + if (THREADP (object)) + return Qt; + else + return Qnil; +} + +DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0, + doc: /* Return t if OBJECT is a mutex. */) + (Lisp_Object object) +{ + if (MUTEXP (object)) + return Qt; + else + return Qnil; +} + +DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p, + 1, 1, 0, + doc: /* Return t if OBJECT is a condition variable. */) + (Lisp_Object object) +{ + if (CONDVARP (object)) + return Qt; + else + return Qnil; +} /* Extract and set components of lists. */ @@ -3024,6 +3061,9 @@ syms_of_data (void) DEFSYM (Qchar_table, "char-table"); DEFSYM (Qbool_vector, "bool-vector"); DEFSYM (Qhash_table, "hash-table"); + DEFSYM (Qthread, "thread"); + DEFSYM (Qmutex, "mutex"); + DEFSYM (Qcondition_variable, "condition-variable"); DEFSYM (Qmisc, "misc"); DEFSYM (Qdefun, "defun"); @@ -3065,6 +3105,9 @@ syms_of_data (void) defsubr (&Ssubrp); defsubr (&Sbyte_code_function_p); defsubr (&Schar_or_string_p); + defsubr (&Sthreadp); + defsubr (&Smutexp); + defsubr (&Scondition_variable_p); defsubr (&Scar); defsubr (&Scdr); defsubr (&Scar_safe); diff --git a/src/emacs.c b/src/emacs.c index 4e439a601b1..b4b726183cf 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -149,10 +149,6 @@ bool running_asynch_code; bool display_arg; #endif -/* An address near the bottom of the stack. - Tells GC how to save a copy of the stack. */ -char *stack_bottom; - #if defined (DOUG_LEA_MALLOC) || defined (GNU_LINUX) /* The address where the heap starts (from the first sbrk (0) call). */ static void *my_heap_start; @@ -650,9 +646,6 @@ close_output_streams (void) int main (int argc, char **argv) { -#if GC_MARK_STACK - Lisp_Object dummy; -#endif char stack_bottom_variable; bool do_initial_setlocale; bool dumping; @@ -668,9 +661,8 @@ main (int argc, char **argv) #endif char *ch_to_dir; -#if GC_MARK_STACK - stack_base = &dummy; -#endif + /* Record (approximately) where the stack begins. */ + stack_bottom = &stack_bottom_variable; #ifdef G_SLICE_ALWAYS_MALLOC /* This is used by the Cygwin build. */ @@ -823,9 +815,6 @@ main (int argc, char **argv) } #endif /* HAVE_SETRLIMIT and RLIMIT_STACK */ - /* Record (approximately) where the stack begins. */ - stack_bottom = &stack_bottom_variable; - clearerr (stdin); #ifndef SYSTEM_MALLOC @@ -1085,6 +1074,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem if (!initialized) { init_alloc_once (); + init_threads_once (); init_obarray (); init_eval_once (); init_charset_once (); @@ -1131,6 +1121,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem } init_alloc (); + init_threads (); if (do_initial_setlocale) { @@ -1430,6 +1421,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif /* HAVE_W32NOTIFY */ #endif /* WINDOWSNT */ + syms_of_threads (); syms_of_profiler (); keys_of_casefiddle (); diff --git a/src/eval.c b/src/eval.c index d6236b6edf2..be9de93bf1f 100644 --- a/src/eval.c +++ b/src/eval.c @@ -32,10 +32,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "xterm.h" #endif -#if !BYTE_MARK_STACK -static -#endif -struct catchtag *catchlist; +/* #if !BYTE_MARK_STACK */ +/* static */ +/* #endif */ +/* struct catchtag *catchlist; */ /* Chain of condition handlers currently in effect. The elements of this chain are contained in the stack frames @@ -43,10 +43,10 @@ struct catchtag *catchlist; When an error is signaled (by calling Fsignal, below), this chain is searched for an element that applies. */ -#if !BYTE_MARK_STACK -static -#endif -struct handler *handlerlist; +/* #if !BYTE_MARK_STACK */ +/* static */ +/* #endif */ +/* struct handler *handlerlist; */ #ifdef DEBUG_GCPRO /* Count levels of GCPRO to detect failure to UNGCPRO. */ @@ -78,19 +78,19 @@ Lisp_Object Vautoload_queue; /* Current number of specbindings allocated in specpdl. */ -ptrdiff_t specpdl_size; +/* ptrdiff_t specpdl_size; */ /* Pointer to beginning of specpdl. */ -struct specbinding *specpdl; +/* struct specbinding *specpdl; */ /* Pointer to first unused element in specpdl. */ -struct specbinding *specpdl_ptr; +/* struct specbinding *specpdl_ptr; */ /* Depth in Lisp evaluations and function calls. */ -static EMACS_INT lisp_eval_depth; +/* static EMACS_INT lisp_eval_depth; */ /* The value of num_nonmacro_input_events as of the last time we started to enter the debugger. If we decide to enter the debugger @@ -178,6 +178,19 @@ init_eval (void) when_entered_debugger = -1; } +#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ + || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) +void +mark_catchlist (struct catchtag *catch) +{ + for (; catch; catch = catch->next) + { + mark_object (catch->tag); + mark_object (catch->val); + } +} +#endif + /* Unwind-protect function used by call_debugger. */ static Lisp_Object @@ -965,8 +978,8 @@ internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object c.next = catchlist; c.tag = tag; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -1019,7 +1032,7 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value) /* Unwind the specpdl stack, and then restore the proper set of handlers. */ unbind_to (catchlist->pdlcount, Qnil); - handlerlist = catchlist->handlerlist; + handlerlist = catchlist->f_handlerlist; catchlist = catchlist->next; } while (! last_time); @@ -1029,7 +1042,7 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value) #ifdef DEBUG_GCPRO gcpro_level = gcprolist ? gcprolist->level + 1 : 0; #endif - lisp_eval_depth = catch->lisp_eval_depth; + lisp_eval_depth = catch->f_lisp_eval_depth; sys_longjmp (catch->jmp, 1); } @@ -1129,8 +1142,8 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, c.tag = Qnil; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -1183,8 +1196,8 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers, c.tag = Qnil; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -1220,8 +1233,8 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, c.tag = Qnil; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -1261,8 +1274,8 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), c.tag = Qnil; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -1304,8 +1317,8 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), c.tag = Qnil; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -3000,6 +3013,52 @@ let_shadows_global_binding_p (Lisp_Object symbol) return 0; } +static Lisp_Object +binding_symbol (const struct specbinding *bind) +{ + if (!CONSP (bind->symbol)) + return bind->symbol; + return XCAR (bind->symbol); +} + +void +do_specbind (struct Lisp_Symbol *sym, struct specbinding *bind, + Lisp_Object value) +{ + switch (sym->redirect) + { + case SYMBOL_PLAINVAL: + if (!sym->constant) + SET_SYMBOL_VAL (sym, value); + else + set_internal (bind->symbol, value, Qnil, 1); + break; + + case SYMBOL_LOCALIZED: + case SYMBOL_FORWARDED: + if ((sym->redirect == SYMBOL_LOCALIZED + || BUFFER_OBJFWDP (SYMBOL_FWD (sym))) + && CONSP (bind->symbol)) + { + Lisp_Object where; + + where = XCAR (XCDR (bind->symbol)); + if (NILP (where) + && sym->redirect == SYMBOL_FORWARDED) + { + Fset_default (XCAR (bind->symbol), value); + return; + } + } + + set_internal (binding_symbol (bind), value, Qnil, 1); + break; + + default: + abort (); + } +} + /* `specpdl_ptr->symbol' is a field which describes which variable is let-bound, so it can be properly undone when we unbind_to. It can have the following two shapes: @@ -3036,11 +3095,9 @@ specbind (Lisp_Object symbol, Lisp_Object value) specpdl_ptr->kind = SPECPDL_LET; specpdl_ptr->v.let.symbol = symbol; specpdl_ptr->v.let.old_value = SYMBOL_VAL (sym); + specpdl_ptr->v.let.saved_value = Qnil; ++specpdl_ptr; - if (!sym->constant) - SET_SYMBOL_VAL (sym, value); - else - set_internal (symbol, value, Qnil, 1); + do_specbind (sym, specpdl_ptr - 1, value); break; case SYMBOL_LOCALIZED: if (SYMBOL_BLV (sym)->frame_local) @@ -3072,7 +3129,7 @@ specbind (Lisp_Object symbol, Lisp_Object value) { specpdl_ptr->kind = SPECPDL_LET_DEFAULT; ++specpdl_ptr; - Fset_default (symbol, value); + do_specbind (sym, specpdl_ptr - 1, value); return; } } @@ -3080,7 +3137,7 @@ specbind (Lisp_Object symbol, Lisp_Object value) specpdl_ptr->kind = SPECPDL_LET; specpdl_ptr++; - set_internal (symbol, value, Qnil, 1); + do_specbind (sym, specpdl_ptr - 1, value); break; } default: emacs_abort (); @@ -3098,6 +3155,72 @@ record_unwind_protect (Lisp_Object (*function) (Lisp_Object), Lisp_Object arg) specpdl_ptr++; } +void +rebind_for_thread_switch (void) +{ + struct specbinding *bind; + + for (bind = specpdl; bind != specpdl_ptr; ++bind) + { + if (bind->kind >= SPECPDL_LET) + { + Lisp_Object value = bind->saved_value; + + bind->saved_value = Qnil; + do_specbind (XSYMBOL (binding_symbol (bind)), bind, value); + } + } +} + +static void +do_one_unbind (const struct specbinding *this_binding, int unwinding) +{ + switch (this_binding->kind) + { + case SPECPDL_UNWIND: + (*specpdl_func (this_binding)) (specpdl_arg (this_binding)); + break; + case SPECPDL_LET: + /* If variable has a trivial value (no forwarding), we can + just set it. No need to check for constant symbols here, + since that was already done by specbind. */ + if (XSYMBOL (specpdl_symbol (this_binding))->redirect + == SYMBOL_PLAINVAL) + SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (this_binding)), + specpdl_old_value (this_binding)); + else + /* NOTE: we only ever come here if make_local_foo was used for + the first time on this var within this let. */ + Fset_default (specpdl_symbol (this_binding), + specpdl_old_value (this_binding)); + break; + case SPECPDL_BACKTRACE: + break; + case SPECPDL_LET_LOCAL: + case SPECPDL_LET_DEFAULT: + { /* If the symbol is a list, it is really (SYMBOL WHERE + . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a + frame. If WHERE is a buffer or frame, this indicates we + bound a variable that had a buffer-local or frame-local + binding. WHERE nil means that the variable had the default + value when it was bound. CURRENT-BUFFER is the buffer that + was current when the variable was bound. */ + Lisp_Object symbol = specpdl_symbol (this_binding); + Lisp_Object where = specpdl_where (this_binding); + eassert (BUFFERP (where)); + + if (this_binding->kind == SPECPDL_LET_DEFAULT) + Fset_default (symbol, specpdl_old_value (this_binding)); + /* If this was a local binding, reset the value in the appropriate + buffer, but only if that buffer's binding still exists. */ + else if (!NILP (Flocal_variable_p (symbol, where))) + set_internal (symbol, specpdl_old_value (this_binding), + where, 1); + } + break; + } +} + Lisp_Object unbind_to (ptrdiff_t count, Lisp_Object value) { @@ -3118,50 +3241,7 @@ unbind_to (ptrdiff_t count, Lisp_Object value) struct specbinding this_binding; this_binding = *--specpdl_ptr; - switch (this_binding.kind) - { - case SPECPDL_UNWIND: - (*specpdl_func (&this_binding)) (specpdl_arg (&this_binding)); - break; - case SPECPDL_LET: - /* If variable has a trivial value (no forwarding), we can - just set it. No need to check for constant symbols here, - since that was already done by specbind. */ - if (XSYMBOL (specpdl_symbol (&this_binding))->redirect - == SYMBOL_PLAINVAL) - SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (&this_binding)), - specpdl_old_value (&this_binding)); - else - /* NOTE: we only ever come here if make_local_foo was used for - the first time on this var within this let. */ - Fset_default (specpdl_symbol (&this_binding), - specpdl_old_value (&this_binding)); - break; - case SPECPDL_BACKTRACE: - break; - case SPECPDL_LET_LOCAL: - case SPECPDL_LET_DEFAULT: - { /* If the symbol is a list, it is really (SYMBOL WHERE - . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a - frame. If WHERE is a buffer or frame, this indicates we - bound a variable that had a buffer-local or frame-local - binding. WHERE nil means that the variable had the default - value when it was bound. CURRENT-BUFFER is the buffer that - was current when the variable was bound. */ - Lisp_Object symbol = specpdl_symbol (&this_binding); - Lisp_Object where = specpdl_where (&this_binding); - eassert (BUFFERP (where)); - - if (this_binding.kind == SPECPDL_LET_DEFAULT) - Fset_default (symbol, specpdl_old_value (&this_binding)); - /* If this was a local binding, reset the value in the appropriate - buffer, but only if that buffer's binding still exists. */ - else if (!NILP (Flocal_variable_p (symbol, where))) - set_internal (symbol, specpdl_old_value (&this_binding), - where, 1); - } - break; - } + do_one_unbind (&this_binding, 1); } if (NILP (Vquit_flag) && !NILP (quitf)) @@ -3171,6 +3251,21 @@ unbind_to (ptrdiff_t count, Lisp_Object value) return value; } +void +unbind_for_thread_switch (void) +{ + struct specbinding *bind; + + for (bind = specpdl_ptr; bind != specpdl; --bind) + { + if (bind->kind >= SPECPDL_LET) + { + bind->saved_value = find_symbol_value (binding_symbol (bind)); + do_one_unbind (bind, 0); + } + } +} + 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 @@ -3280,10 +3375,10 @@ If NFRAMES is more than the number of frames, the value is nil. */) void -mark_specpdl (void) +mark_specpdl (struct specbinding *first, struct specbinding *ptr) { struct specbinding *pdl; - for (pdl = specpdl; pdl != specpdl_ptr; pdl++) + for (pdl = first; pdl != ptr; pdl++) { switch (pdl->kind) { @@ -3306,6 +3401,7 @@ mark_specpdl (void) case SPECPDL_LET: mark_object (specpdl_symbol (pdl)); mark_object (specpdl_old_value (pdl)); + mark_object (specpdl_saved_value (pdl)); } } } diff --git a/src/lisp.h b/src/lisp.h index 517d0abbb61..c8732d125cc 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -32,6 +32,8 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <intprops.h> +#include "systhread.h" + INLINE_HEADER_BEGIN #ifndef LISP_INLINE # define LISP_INLINE INLINE @@ -418,6 +420,9 @@ enum pvec_type PVEC_WINDOW_CONFIGURATION, PVEC_SUBR, PVEC_OTHER, + PVEC_THREAD, + PVEC_MUTEX, + PVEC_CONDVAR, /* These should be last, check internal_equal to see why. */ PVEC_COMPILED, PVEC_CHAR_TABLE, @@ -607,6 +612,9 @@ LISP_INLINE Lisp_Object make_lisp_proc (struct Lisp_Process *p) #define XBOOL_VECTOR(a) (eassert (BOOL_VECTOR_P (a)), \ ((struct Lisp_Bool_Vector *) \ XUNTAG (a, Lisp_Vectorlike))) +#define XTHREAD(a) (eassert (THREADP (a)), (struct thread_state *) XPNTR(a)) +#define XMUTEX(a) (eassert (MUTEXP (a)), (struct Lisp_Mutex *) XPNTR(a)) +#define XCONDVAR(a) (eassert (CONDVARP (a)), (struct Lisp_CondVar *) XPNTR(a)) /* Construct a Lisp_Object from a value or address. */ @@ -655,6 +663,9 @@ LISP_INLINE Lisp_Object make_lisp_proc (struct Lisp_Process *p) #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) #define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE)) +#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD)) +#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX)) +#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR)) /* Convenience macros for dealing with Lisp arrays. */ @@ -1887,6 +1898,9 @@ XSAVE_OBJECT (Lisp_Object obj, int n) #define SUB_CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_SUB_CHAR_TABLE) #define BOOL_VECTOR_P(x) PSEUDOVECTORP (x, PVEC_BOOL_VECTOR) #define FRAMEP(x) PSEUDOVECTORP (x, PVEC_FRAME) +#define THREADP(x) PSEUDOVECTORP (x, PVEC_THREAD) +#define MUTEXP(x) PSEUDOVECTORP (x, PVEC_MUTEX) +#define CONDVARP(x) PSEUDOVECTORP (x, PVEC_CONDVAR) /* Test for image (image . spec) */ #define IMAGEP(x) (CONSP (x) && EQ (XCAR (x), Qimage)) @@ -1994,6 +2008,15 @@ XSAVE_OBJECT (Lisp_Object obj, int n) #define CHECK_OVERLAY(x) \ CHECK_TYPE (OVERLAYP (x), Qoverlayp, x) +#define CHECK_THREAD(x) \ + CHECK_TYPE (THREADP (x), Qthreadp, x) + +#define CHECK_MUTEX(x) \ + CHECK_TYPE (MUTEXP (x), Qmutexp, x) + +#define CHECK_CONDVAR(x) \ + CHECK_TYPE (CONDVARP (x), Qcondition_variablep, x) + /* Since we can't assign directly to the CAR or CDR fields of a cons cell, use these when checking that those fields contain numbers. */ #define CHECK_NUMBER_CAR(x) \ @@ -2235,6 +2258,9 @@ struct specbinding struct { /* `where' is not used in the case of SPECPDL_LET. */ Lisp_Object symbol, old_value, where; + /* Normally this is unused; but it is to the symbol's current + value when a thread is swapped out. */ + Lisp_Object saved_value; } let; struct { Lisp_Object function; @@ -2251,6 +2277,9 @@ LISP_INLINE Lisp_Object specpdl_symbol (struct specbinding *pdl) LISP_INLINE Lisp_Object specpdl_old_value (struct specbinding *pdl) { eassert (pdl->kind >= SPECPDL_LET); return pdl->v.let.old_value; } +LISP_INLINE Lisp_Object specpdl_saved_value (struct specbinding *pdl) +{ eassert (pdl->kind >= SPECPDL_LET); return pdl->v.let.saved_value; } + LISP_INLINE Lisp_Object specpdl_where (struct specbinding *pdl) { eassert (pdl->kind > SPECPDL_LET); return pdl->v.let.where; } @@ -2272,9 +2301,9 @@ LISP_INLINE Lisp_Object *backtrace_args (struct specbinding *pdl) LISP_INLINE bool backtrace_debug_on_exit (struct specbinding *pdl) { eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.debug_on_exit; } -extern struct specbinding *specpdl; -extern struct specbinding *specpdl_ptr; -extern ptrdiff_t specpdl_size; +/* extern struct specbinding *specpdl; */ +/* extern struct specbinding *specpdl_ptr; */ +/* extern ptrdiff_t specpdl_size; */ #define SPECPDL_INDEX() (specpdl_ptr - specpdl) @@ -2336,8 +2365,8 @@ struct catchtag struct gcpro *gcpro; #endif sys_jmp_buf jmp; - struct handler *handlerlist; - EMACS_INT lisp_eval_depth; + struct handler *f_handlerlist; + EMACS_INT f_lisp_eval_depth; ptrdiff_t volatile pdlcount; int poll_suppress_count; int interrupt_input_blocked; @@ -2346,10 +2375,6 @@ struct catchtag extern Lisp_Object memory_signal_data; -/* An address near the bottom of the stack. - Tells GC how to save a copy of the stack. */ -extern char *stack_bottom; - /* Check quit-flag and quit if it is non-nil. Typing C-g does not directly cause a quit; it only sets Vquit_flag. So the program needs to do QUIT at times when it is safe to quit. @@ -2399,8 +2424,6 @@ extern Lisp_Object Vascii_canon_table; Every function that can call Feval must protect in this fashion all Lisp_Object variables whose contents will be used again. */ -extern struct gcpro *gcprolist; - struct gcpro { struct gcpro *next; @@ -2509,8 +2532,6 @@ struct gcpro #else -extern int gcpro_level; - #define GCPRO1(varname) \ {gcpro1.next = gcprolist; gcpro1.var = &varname; gcpro1.nvars = 1; \ gcpro1.level = gcpro_level++; \ @@ -2839,6 +2860,7 @@ extern Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp; extern Lisp_Object Qbuffer_or_string_p; extern Lisp_Object Qfboundp; extern Lisp_Object Qchar_table_p, Qvector_or_char_table_p; +extern Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep; extern Lisp_Object Qcdr; @@ -3106,9 +3128,12 @@ extern void mark_object (Lisp_Object); #if defined REL_ALLOC && !defined SYSTEM_MALLOC extern void refill_memory_reserve (void); #endif +#if GC_MARK_STACK +extern void mark_stack (char *, char *); +#endif +extern void flush_stack_call_func (void (*func) (void *arg), void *arg); extern const char *pending_malloc_warning; extern Lisp_Object zero_vector; -extern Lisp_Object *stack_base; extern EMACS_INT consing_since_gc; extern EMACS_INT gc_relative_threshold; extern EMACS_INT memory_full_cons_threshold; @@ -3339,9 +3364,10 @@ extern Lisp_Object Qand_rest; extern Lisp_Object Vautoload_queue; extern Lisp_Object Vsignaling_function; extern Lisp_Object inhibit_lisp_code; -#if BYTE_MARK_STACK -extern struct catchtag *catchlist; -extern struct handler *handlerlist; +extern int handling_signal; +#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ + || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) +extern void mark_catchlist (struct catchtag *); #endif /* To run a normal hook, use the appropriate function from the list below. The calling convention: @@ -3383,6 +3409,8 @@ extern Lisp_Object internal_condition_case_n extern void specbind (Lisp_Object, Lisp_Object); extern void record_unwind_protect (Lisp_Object (*) (Lisp_Object), Lisp_Object); extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object); +extern void rebind_for_thread_switch (void); +extern void unbind_for_thread_switch (void); extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); extern _Noreturn void verror (const char *, va_list) ATTRIBUTE_FORMAT_PRINTF (1, 0); @@ -3396,13 +3424,16 @@ extern void init_eval (void); extern void syms_of_eval (void); extern void record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs); -extern void mark_specpdl (void); +extern void mark_specpdl (struct specbinding *first, struct 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 bool let_shadows_global_binding_p (Lisp_Object symbol); +/* Defined in thread.c. */ +extern void mark_threads (void); + /* Defined in editfns.c. */ extern Lisp_Object Qfield; extern void insert1 (Lisp_Object); @@ -3665,11 +3696,10 @@ extern int read_bytecode_char (bool); /* Defined in bytecode.c. */ extern void syms_of_bytecode (void); -extern struct byte_stack *byte_stack_list; #if BYTE_MARK_STACK -extern void mark_byte_stack (void); +extern void mark_byte_stack (struct byte_stack *); #endif -extern void unmark_byte_stack (void); +extern void unmark_byte_stack (struct byte_stack *); extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, ptrdiff_t, Lisp_Object *); @@ -3956,6 +3986,7 @@ extern void *record_xmalloc (size_t); #include "globals.h" +#include "thread.h" /* Check whether it's time for GC, and run it if so. */ diff --git a/src/print.c b/src/print.c index 811ab5011ce..979b732a057 100644 --- a/src/print.c +++ b/src/print.c @@ -1939,6 +1939,42 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) } PRINTCHAR ('>'); } + else if (THREADP (obj)) + { + strout ("#<thread ", -1, -1, printcharfun); + if (STRINGP (XTHREAD (obj)->name)) + print_string (XTHREAD (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XTHREAD (obj)); + strout (buf, len, len, printcharfun); + } + PRINTCHAR ('>'); + } + else if (MUTEXP (obj)) + { + strout ("#<mutex ", -1, -1, printcharfun); + if (STRINGP (XMUTEX (obj)->name)) + print_string (XMUTEX (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XMUTEX (obj)); + strout (buf, len, len, printcharfun); + } + PRINTCHAR ('>'); + } + else if (CONDVARP (obj)) + { + strout ("#<condvar ", -1, -1, printcharfun); + if (STRINGP (XCONDVAR (obj)->name)) + print_string (XCONDVAR (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XCONDVAR (obj)); + strout (buf, len, len, printcharfun); + } + PRINTCHAR ('>'); + } else { ptrdiff_t size = ASIZE (obj); diff --git a/src/process.c b/src/process.c index 9df003fa3a3..c1726e7ad60 100644 --- a/src/process.c +++ b/src/process.c @@ -263,38 +263,13 @@ static void create_pty (Lisp_Object); static Lisp_Object get_process (register Lisp_Object name); static void exec_sentinel (Lisp_Object proc, Lisp_Object reason); -/* Mask of bits indicating the descriptors that we wait for input on. */ - -static SELECT_TYPE input_wait_mask; - -/* Mask that excludes keyboard input descriptor(s). */ - -static SELECT_TYPE non_keyboard_wait_mask; - -/* Mask that excludes process input descriptor(s). */ - -static SELECT_TYPE non_process_wait_mask; - -/* Mask for selecting for write. */ - -static SELECT_TYPE write_mask; - #ifdef NON_BLOCKING_CONNECT -/* Mask of bits indicating the descriptors that we wait for connect to - complete on. Once they complete, they are removed from this mask - and added to the input_wait_mask and non_keyboard_wait_mask. */ - -static SELECT_TYPE connect_wait_mask; - /* Number of bits set in connect_wait_mask. */ static int num_pending_connects; #endif /* NON_BLOCKING_CONNECT */ -/* The largest descriptor currently in use for a process object. */ -static int max_process_desc; - /* The largest descriptor currently in use for input. */ -static int max_input_desc; +static int max_desc; /* Indexed by descriptor, gives the process (if any) for that descriptor */ static Lisp_Object chan_process[MAXDESC]; @@ -374,6 +349,11 @@ pset_mark (struct Lisp_Process *p, Lisp_Object val) p->mark = val; } static void +pset_thread (struct Lisp_Process *p, Lisp_Object val) +{ + p->thread = val; +} +static void pset_name (struct Lisp_Process *p, Lisp_Object val) { p->name = val; @@ -411,13 +391,34 @@ pset_write_queue (struct Lisp_Process *p, Lisp_Object val) +enum fd_bits +{ + /* Read from file descriptor. */ + FOR_READ = 1, + /* Write to file descriptor. */ + FOR_WRITE = 2, + /* This descriptor refers to a keyboard. Only valid if FOR_READ is + set. */ + KEYBOARD_FD = 4, + /* This descriptor refers to a process. */ + PROCESS_FD = 8, + /* A non-blocking connect. Only valid if FOR_WRITE is set. */ + NON_BLOCKING_CONNECT_FD = 16 +}; + static struct fd_callback_data { fd_callback func; void *data; -#define FOR_READ 1 -#define FOR_WRITE 2 - int condition; /* mask of the defines above. */ + /* Flags from enum fd_bits. */ + int flags; + /* If this fd is locked to a certain thread, this points to it. + Otherwise, this is NULL. If an fd is locked to a thread, then + only that thread is permitted to wait on it. */ + struct thread_state *thread; + /* If this fd is currently being selected on by a thread, this + points to the thread. Otherwise it is NULL. */ + struct thread_state *waiting_thread; } fd_callback_info[MAXDESC]; @@ -432,7 +433,23 @@ add_read_fd (int fd, fd_callback func, void *data) fd_callback_info[fd].func = func; fd_callback_info[fd].data = data; - fd_callback_info[fd].condition |= FOR_READ; +} + +static void +add_non_keyboard_read_fd (int fd) +{ + eassert (fd >= 0 && fd < MAXDESC); + eassert (fd_callback_info[fd].func == NULL); + fd_callback_info[fd].flags |= FOR_READ; + if (fd > max_desc) + max_desc = fd; +} + +static void +add_process_read_fd (int fd) +{ + add_non_keyboard_read_fd (fd); + fd_callback_info[fd].flags |= PROCESS_FD; } /* Stop monitoring file descriptor FD for when read is possible. */ @@ -441,10 +458,10 @@ void delete_read_fd (int fd) { eassert (fd < MAXDESC); + eassert (fd <= max_desc); delete_keyboard_wait_descriptor (fd); - fd_callback_info[fd].condition &= ~FOR_READ; - if (fd_callback_info[fd].condition == 0) + if (fd_callback_info[fd].flags == 0) { fd_callback_info[fd].func = 0; fd_callback_info[fd].data = 0; @@ -458,13 +475,39 @@ void add_write_fd (int fd, fd_callback func, void *data) { eassert (fd < MAXDESC); - FD_SET (fd, &write_mask); - if (fd > max_input_desc) - max_input_desc = fd; + if (fd > max_desc) + max_desc = fd; fd_callback_info[fd].func = func; fd_callback_info[fd].data = data; - fd_callback_info[fd].condition |= FOR_WRITE; + fd_callback_info[fd].flags |= FOR_WRITE; +} + +static void +add_non_blocking_write_fd (int fd) +{ + eassert (fd >= 0 && fd < MAXDESC); + eassert (fd_callback_info[fd].func == NULL); + + fd_callback_info[fd].flags |= FOR_WRITE | NON_BLOCKING_CONNECT_FD; + if (fd > max_desc) + max_desc = fd; + ++num_pending_connects; +} + +static void +recompute_max_desc (void) +{ + int fd; + + for (fd = max_desc; fd >= 0; --fd) + { + if (fd_callback_info[fd].flags != 0) + { + max_desc = fd; + break; + } + } } /* Stop monitoring file descriptor FD for when write is possible. */ @@ -472,24 +515,126 @@ add_write_fd (int fd, fd_callback func, void *data) void delete_write_fd (int fd) { - int lim = max_input_desc; + int lim = max_desc; eassert (fd < MAXDESC); - FD_CLR (fd, &write_mask); - fd_callback_info[fd].condition &= ~FOR_WRITE; - if (fd_callback_info[fd].condition == 0) + eassert (fd <= max_desc); + + if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0) + { + if (--num_pending_connects < 0) + abort (); + } + fd_callback_info[fd].flags &= ~(FOR_WRITE | NON_BLOCKING_CONNECT_FD); + if (fd_callback_info[fd].flags == 0) { fd_callback_info[fd].func = 0; fd_callback_info[fd].data = 0; - if (fd == max_input_desc) - for (fd = lim; fd >= 0; fd--) - if (FD_ISSET (fd, &input_wait_mask) || FD_ISSET (fd, &write_mask)) - { - max_input_desc = fd; - break; - } + if (fd == max_desc) + recompute_max_desc (); + } +} + +static void +compute_input_wait_mask (SELECT_TYPE *mask) +{ + int fd; + + FD_ZERO (mask); + for (fd = 0; fd <= max_desc; ++fd) + { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; + if ((fd_callback_info[fd].flags & FOR_READ) != 0) + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } + } +} + +static void +compute_non_process_wait_mask (SELECT_TYPE *mask) +{ + int fd; + + FD_ZERO (mask); + for (fd = 0; fd <= max_desc; ++fd) + { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; + if ((fd_callback_info[fd].flags & FOR_READ) != 0 + && (fd_callback_info[fd].flags & PROCESS_FD) == 0) + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } + } +} + +static void +compute_non_keyboard_wait_mask (SELECT_TYPE *mask) +{ + int fd; + + FD_ZERO (mask); + for (fd = 0; fd <= max_desc; ++fd) + { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; + if ((fd_callback_info[fd].flags & FOR_READ) != 0 + && (fd_callback_info[fd].flags & KEYBOARD_FD) == 0) + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } + } +} + +static void +compute_write_mask (SELECT_TYPE *mask) +{ + int fd; + + FD_ZERO (mask); + for (fd = 0; fd <= max_desc; ++fd) + { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; + if ((fd_callback_info[fd].flags & FOR_WRITE) != 0) + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } + } +} + +static void +clear_waiting_thread_info (void) +{ + int fd; + for (fd = 0; fd <= max_desc; ++fd) + { + if (fd_callback_info[fd].waiting_thread == current_thread) + fd_callback_info[fd].waiting_thread = NULL; } } @@ -681,6 +826,7 @@ make_process (Lisp_Object name) Lisp data to nil, so do it only for slots which should not be nil. */ pset_status (p, Qrun); pset_mark (p, Fmake_marker ()); + pset_thread (p, Fcurrent_thread ()); /* Initialize non-Lisp data. Note that allocate_process zeroes out all non-Lisp data, so do it only for slots which should not be zero. */ @@ -720,6 +866,27 @@ remove_process (register Lisp_Object proc) deactivate_process (proc); } +void +update_processes_for_thread_death (Lisp_Object dying_thread) +{ + Lisp_Object pair; + + for (pair = Vprocess_alist; !NILP (pair); pair = XCDR (pair)) + { + Lisp_Object process = XCDR (XCAR (pair)); + if (EQ (XPROCESS (process)->thread, dying_thread)) + { + struct Lisp_Process *proc = XPROCESS (process); + + proc->thread = Qnil; + if (proc->infd >= 0) + fd_callback_info[proc->infd].thread = NULL; + if (proc->outfd >= 0) + fd_callback_info[proc->outfd].thread = NULL; + } + } +} + DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0, doc: /* Return t if OBJECT is a process. */) @@ -1018,17 +1185,11 @@ The string argument is normally a multibyte string, except: if (p->infd >= 0) { if (EQ (filter, Qt) && !EQ (p->status, Qlisten)) - { - FD_CLR (p->infd, &input_wait_mask); - FD_CLR (p->infd, &non_keyboard_wait_mask); - } + delete_read_fd (p->infd); else if (EQ (p->filter, Qt) /* Network or serial process not stopped: */ && !EQ (p->command, Qt)) - { - FD_SET (p->infd, &input_wait_mask); - FD_SET (p->infd, &non_keyboard_wait_mask); - } + delete_read_fd (p->infd); } pset_filter (p, filter); @@ -1079,6 +1240,42 @@ See `set-process-sentinel' for more info on sentinels. */) return XPROCESS (process)->sentinel; } +DEFUN ("set-process-thread", Fset_process_thread, Sset_process_thread, + 2, 2, 0, + doc: /* FIXME */) + (Lisp_Object process, Lisp_Object thread) +{ + struct Lisp_Process *proc; + struct thread_state *tstate; + + CHECK_PROCESS (process); + if (NILP (thread)) + tstate = NULL; + else + { + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + } + + proc = XPROCESS (process); + proc->thread = thread; + if (proc->infd >= 0) + fd_callback_info[proc->infd].thread = tstate; + if (proc->outfd >= 0) + fd_callback_info[proc->outfd].thread = tstate; + + return thread; +} + +DEFUN ("process-thread", Fprocess_thread, Sprocess_thread, + 1, 1, 0, + doc: /* FIXME */) + (Lisp_Object process) +{ + CHECK_PROCESS (process); + return XPROCESS (process)->thread; +} + DEFUN ("set-process-window-size", Fset_process_window_size, Sset_process_window_size, 3, 3, 0, doc: /* Tell PROCESS that it has logical window size HEIGHT and WIDTH. */) @@ -1672,10 +1869,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) XPROCESS (process)->pty_flag = pty_flag; pset_status (XPROCESS (process), Qrun); - FD_SET (inchannel, &input_wait_mask); - FD_SET (inchannel, &non_keyboard_wait_mask); - if (inchannel > max_process_desc) - max_process_desc = inchannel; + add_process_read_fd (inchannel); /* This may signal an error. */ setup_process_coding_systems (process); @@ -1929,10 +2123,7 @@ create_pty (Lisp_Object process) pset_status (XPROCESS (process), Qrun); setup_process_coding_systems (process); - FD_SET (inchannel, &input_wait_mask); - FD_SET (inchannel, &non_keyboard_wait_mask); - if (inchannel > max_process_desc) - max_process_desc = inchannel; + add_process_read_fd (inchannel); XPROCESS (process)->pid = -2; #ifdef HAVE_PTYS @@ -2554,8 +2745,8 @@ usage: (make-serial-process &rest ARGS) */) fd = serial_open (SSDATA (port)); p->infd = fd; p->outfd = fd; - if (fd > max_process_desc) - max_process_desc = fd; + if (fd > max_desc) + max_desc = fd; chan_process[fd] = proc; buffer = Fplist_get (contact, QCbuffer); @@ -2577,10 +2768,7 @@ usage: (make-serial-process &rest ARGS) */) p->pty_flag = 0; if (!EQ (p->command, Qt)) - { - FD_SET (fd, &input_wait_mask); - FD_SET (fd, &non_keyboard_wait_mask); - } + add_non_keyboard_read_fd (fd); if (BUFFERP (buffer)) { @@ -3380,12 +3568,8 @@ usage: (make-network-process &rest ARGS) */) in that case, we still need to signal this like a non-blocking connection. */ pset_status (p, Qconnect); - if (!FD_ISSET (inch, &connect_wait_mask)) - { - FD_SET (inch, &connect_wait_mask); - FD_SET (inch, &write_mask); - num_pending_connects++; - } + if ((fd_callback_info[inch].flags & NON_BLOCKING_CONNECT_FD) == 0) + add_non_blocking_write_fd (inch); } else #endif @@ -3393,13 +3577,10 @@ usage: (make-network-process &rest ARGS) */) still listen for incoming connects unless it is stopped. */ if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt)) || (EQ (p->status, Qlisten) && NILP (p->command))) - { - FD_SET (inch, &input_wait_mask); - FD_SET (inch, &non_keyboard_wait_mask); - } + add_non_keyboard_read_fd (inch); - if (inch > max_process_desc) - max_process_desc = inch; + if (inch > max_desc) + max_desc = inch; tem = Fplist_member (contact, QCcoding); if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) @@ -3840,27 +4021,13 @@ deactivate_process (Lisp_Object proc) } #endif chan_process[inchannel] = Qnil; - FD_CLR (inchannel, &input_wait_mask); - FD_CLR (inchannel, &non_keyboard_wait_mask); + delete_read_fd (inchannel); #ifdef NON_BLOCKING_CONNECT - if (FD_ISSET (inchannel, &connect_wait_mask)) - { - FD_CLR (inchannel, &connect_wait_mask); - FD_CLR (inchannel, &write_mask); - if (--num_pending_connects < 0) - emacs_abort (); - } + if ((fd_callback_info[inchannel].flags & NON_BLOCKING_CONNECT_FD) != 0) + delete_write_fd (inchannel); #endif - if (inchannel == max_process_desc) - { - int i; - /* We just closed the highest-numbered process input descriptor, - so recompute the highest-numbered one now. */ - max_process_desc = 0; - for (i = 0; i < MAXDESC; i++) - if (!NILP (chan_process[i])) - max_process_desc = i; - } + if (inchannel == max_desc) + recompute_max_desc (); } } @@ -3888,7 +4055,17 @@ Return non-nil if we received any output before the timeout expired. */) int nsecs; if (! NILP (process)) - CHECK_PROCESS (process); + { + struct Lisp_Process *procp; + + CHECK_PROCESS (process); + procp = XPROCESS (process); + + /* Can't wait for a process that is dedicated to a different + thread. */ + if (!EQ (procp->thread, Qnil) && !EQ (procp->thread, Fcurrent_thread ())) + error ("FIXME"); + } else just_this_one = Qnil; @@ -4108,13 +4285,7 @@ server_accept_connection (Lisp_Object server, int channel) /* Client processes for accepted connections are not stopped initially. */ if (!EQ (p->filter, Qt)) - { - FD_SET (s, &input_wait_mask); - FD_SET (s, &non_keyboard_wait_mask); - } - - if (s > max_process_desc) - max_process_desc = s; + add_non_keyboard_read_fd (s); /* Setup coding system for new process based on server process. This seems to be the proper thing to do, as the coding system @@ -4144,20 +4315,10 @@ server_accept_connection (Lisp_Object server, int channel) build_string ("\n"))); } -/* This variable is different from waiting_for_input in keyboard.c. - It is used to communicate to a lisp process-filter/sentinel (via the - function Fwaiting_for_user_input_p below) whether Emacs was waiting - for user-input when that process-filter was called. - waiting_for_input cannot be used as that is by definition 0 when - lisp code is being evalled. - This is also used in record_asynch_buffer_change. - For that purpose, this must be 0 - when not inside wait_reading_process_output. */ -static int waiting_for_user_input_p; - static Lisp_Object wait_reading_process_output_unwind (Lisp_Object data) { + clear_waiting_thread_info (); waiting_for_user_input_p = XINT (data); return Qnil; } @@ -4225,6 +4386,10 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, bool got_some_input = 0; ptrdiff_t count = SPECPDL_INDEX (); + eassert (wait_proc == NULL + || EQ (wait_proc->thread, Qnil) + || XTHREAD (wait_proc->thread) == current_thread); + FD_ZERO (&Available); FD_ZERO (&Writeok); @@ -4374,18 +4539,18 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (kbd_on_hold_p ()) FD_ZERO (&Atemp); else - Atemp = input_wait_mask; - Ctemp = write_mask; + compute_input_wait_mask (&Atemp); + compute_write_mask (&Ctemp); timeout = make_emacs_time (0, 0); - if ((pselect (max (max_process_desc, max_input_desc) + 1, - &Atemp, + if ((thread_select (pselect, max_desc + 1, + &Atemp, #ifdef NON_BLOCKING_CONNECT - (num_pending_connects > 0 ? &Ctemp : NULL), + (num_pending_connects > 0 ? &Ctemp : NULL), #else - NULL, + NULL, #endif - NULL, &timeout, NULL) + NULL, &timeout, NULL) <= 0)) { /* It's okay for us to do this and then continue with @@ -4447,17 +4612,17 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } else if (!NILP (wait_for_cell)) { - Available = non_process_wait_mask; + compute_non_process_wait_mask (&Available); check_delay = 0; check_write = 0; } else { if (! read_kbd) - Available = non_keyboard_wait_mask; + compute_non_keyboard_wait_mask (&Available); else - Available = input_wait_mask; - Writeok = write_mask; + compute_input_wait_mask (&Available); + compute_write_mask (&Writeok); #ifdef SELECT_CANT_DO_WRITE_MASK check_write = 0; #else @@ -4505,7 +4670,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, int nsecs = EMACS_NSECS (timeout); if (EMACS_SECS (timeout) > 0 || nsecs > READ_OUTPUT_DELAY_MAX) nsecs = READ_OUTPUT_DELAY_MAX; - for (channel = 0; check_delay > 0 && channel <= max_process_desc; channel++) + for (channel = 0; check_delay > 0 && channel <= max_desc; channel++) { proc = chan_process[channel]; if (NILP (proc)) @@ -4527,18 +4692,18 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, process_output_skip = 0; } #endif - + nfds = thread_select ( #if defined (USE_GTK) || defined (HAVE_GCONF) || defined (HAVE_GSETTINGS) - nfds = xg_select + xg_select #elif defined (HAVE_NS) - nfds = ns_select + ns_select #else - nfds = pselect + pselect #endif - (max (max_process_desc, max_input_desc) + 1, - &Available, - (check_write ? &Writeok : (SELECT_TYPE *)0), - NULL, &timeout, NULL); + , max_desc + 1, + &Available, + (check_write ? &Writeok : (SELECT_TYPE *)0), + NULL, &timeout, NULL); #ifdef HAVE_GNUTLS /* GnuTLS buffers data internally. In lowat mode it leaves @@ -4706,22 +4871,22 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (no_avail || nfds == 0) continue; - for (channel = 0; channel <= max_input_desc; ++channel) + for (channel = 0; channel <= max_desc; ++channel) { struct fd_callback_data *d = &fd_callback_info[channel]; if (d->func - && ((d->condition & FOR_READ + && ((d->flags & FOR_READ && FD_ISSET (channel, &Available)) - || (d->condition & FOR_WRITE - && FD_ISSET (channel, &write_mask)))) + || (d->flags & FOR_WRITE + && FD_ISSET (channel, &Writeok)))) d->func (channel, d->data); } - for (channel = 0; channel <= max_process_desc; channel++) + for (channel = 0; channel <= max_desc; channel++) { if (FD_ISSET (channel, &Available) - && FD_ISSET (channel, &non_keyboard_wait_mask) - && !FD_ISSET (channel, &non_process_wait_mask)) + && ((fd_callback_info[channel].flags & (KEYBOARD_FD | PROCESS_FD)) + == PROCESS_FD)) { int nread; @@ -4789,8 +4954,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, /* Clear the descriptor now, so we only raise the signal once. */ - FD_CLR (channel, &input_wait_mask); - FD_CLR (channel, &non_keyboard_wait_mask); + delete_read_fd (channel); if (p->pid == -2) { @@ -4820,14 +4984,12 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } #ifdef NON_BLOCKING_CONNECT if (FD_ISSET (channel, &Writeok) - && FD_ISSET (channel, &connect_wait_mask)) + && (fd_callback_info[channel].flags + & NON_BLOCKING_CONNECT_FD) != 0) { struct Lisp_Process *p; - FD_CLR (channel, &connect_wait_mask); - FD_CLR (channel, &write_mask); - if (--num_pending_connects < 0) - emacs_abort (); + delete_write_fd (channel); proc = chan_process[channel]; if (NILP (proc)) @@ -4874,10 +5036,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, from the process before calling the sentinel. */ exec_sentinel (proc, build_string ("open\n")); if (!EQ (p->filter, Qt) && !EQ (p->command, Qt)) - { - FD_SET (p->infd, &input_wait_mask); - FD_SET (p->infd, &non_keyboard_wait_mask); - } + delete_read_fd (p->infd); } } #endif /* NON_BLOCKING_CONNECT */ @@ -5863,10 +6022,7 @@ traffic. */) p = XPROCESS (process); if (NILP (p->command) && p->infd >= 0) - { - FD_CLR (p->infd, &input_wait_mask); - FD_CLR (p->infd, &non_keyboard_wait_mask); - } + delete_read_fd (p->infd); pset_command (p, Qt); return process; } @@ -5894,8 +6050,7 @@ traffic. */) && p->infd >= 0 && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten))) { - FD_SET (p->infd, &input_wait_mask); - FD_SET (p->infd, &non_keyboard_wait_mask); + add_non_keyboard_read_fd (p->infd); #ifdef WINDOWSNT if (fd_info[ p->infd ].flags & FILE_SERIAL) PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR); @@ -6177,10 +6332,7 @@ handle_child_signal (int sig) /* clear_desc_flag avoids a compiler bug in Microsoft C. */ if (clear_desc_flag) - { - FD_CLR (p->infd, &input_wait_mask); - FD_CLR (p->infd, &non_keyboard_wait_mask); - } + delete_read_fd (p->infd); } } } @@ -6523,9 +6675,9 @@ keyboard_bit_set (fd_set *mask) { int fd; - for (fd = 0; fd <= max_input_desc; fd++) - if (FD_ISSET (fd, mask) && FD_ISSET (fd, &input_wait_mask) - && !FD_ISSET (fd, &non_keyboard_wait_mask)) + for (fd = 0; fd <= max_desc; fd++) + if (FD_ISSET (fd, mask) + && ((fd_callback_info[fd].flags & KEYBOARD_FD) != 0)) return 1; return 0; @@ -6770,10 +6922,10 @@ void add_keyboard_wait_descriptor (int desc) { #ifdef subprocesses /* actually means "not MSDOS" */ - FD_SET (desc, &input_wait_mask); - FD_SET (desc, &non_process_wait_mask); - if (desc > max_input_desc) - max_input_desc = desc; + eassert (desc >= 0 && desc < MAXDESC); + fd_callback_info[desc].flags |= FOR_READ | KEYBOARD_FD; + if (desc > max_desc) + max_desc = desc; #endif } @@ -6784,15 +6936,15 @@ delete_keyboard_wait_descriptor (int desc) { #ifdef subprocesses int fd; - int lim = max_input_desc; + int lim = max_desc; + + eassert (desc >= 0 && desc < MAXDESC); + eassert (desc <= max_desc); - FD_CLR (desc, &input_wait_mask); - FD_CLR (desc, &non_process_wait_mask); + fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD); - if (desc == max_input_desc) - for (fd = 0; fd < lim; fd++) - if (FD_ISSET (fd, &input_wait_mask) || FD_ISSET (fd, &write_mask)) - max_input_desc = fd; + if (desc == max_desc) + recompute_max_desc (); #endif } @@ -7057,15 +7209,10 @@ init_process_emacs (void) catch_child_signal (); } - FD_ZERO (&input_wait_mask); - FD_ZERO (&non_keyboard_wait_mask); - FD_ZERO (&non_process_wait_mask); - FD_ZERO (&write_mask); - max_process_desc = 0; + max_desc = 0; memset (fd_callback_info, 0, sizeof (fd_callback_info)); #ifdef NON_BLOCKING_CONNECT - FD_ZERO (&connect_wait_mask); num_pending_connects = 0; #endif @@ -7297,6 +7444,8 @@ The variable takes effect when `start-process' is called. */); defsubr (&Sprocess_filter); defsubr (&Sset_process_sentinel); defsubr (&Sprocess_sentinel); + defsubr (&Sset_process_thread); + defsubr (&Sprocess_thread); defsubr (&Sset_process_window_size); defsubr (&Sset_process_inherit_coding_system_flag); defsubr (&Sset_process_query_on_exit_flag); diff --git a/src/process.h b/src/process.h index 9455df18beb..cf1e0ea1d44 100644 --- a/src/process.h +++ b/src/process.h @@ -103,6 +103,9 @@ struct Lisp_Process Lisp_Object gnutls_cred_type; #endif + /* The thread a process is linked to, or nil for any thread. */ + Lisp_Object thread; + /* After this point, there are no Lisp_Objects any more. */ /* alloc.c assumes that `pid' is the first such non-Lisp slot. */ @@ -219,4 +222,6 @@ extern void add_write_fd (int fd, fd_callback func, void *data); extern void delete_write_fd (int fd); extern void catch_child_signal (void); +extern void update_processes_for_thread_death (Lisp_Object); + INLINE_HEADER_END diff --git a/src/regex.c b/src/regex.c index 79fb28ba12a..73a735cea65 100644 --- a/src/regex.c +++ b/src/regex.c @@ -1210,12 +1210,14 @@ print_double_string (re_char *where, re_char *string1, ssize_t size1, # define IF_LINT(Code) /* empty */ #endif +#ifndef emacs /* Set by `re_set_syntax' to the current regexp syntax to recognize. Can also be assigned to arbitrarily: each pattern buffer stores its own syntax, so it can be changed between regex compilations. */ /* This has no initializer because initialized variables in Emacs become read-only after dumping. */ reg_syntax_t re_syntax_options; +#endif /* Specify the precise syntax of regexps for compilation. This provides @@ -1235,8 +1237,10 @@ re_set_syntax (reg_syntax_t syntax) } WEAK_ALIAS (__re_set_syntax, re_set_syntax) +#ifndef emacs /* Regexp to use to replace spaces, or NULL meaning don't. */ static re_char *whitespace_regexp; +#endif void re_set_whitespace_regexp (const char *regexp) @@ -4878,12 +4882,6 @@ re_match (struct re_pattern_buffer *bufp, const char *string, WEAK_ALIAS (__re_match, re_match) #endif /* not emacs */ -#ifdef emacs -/* In Emacs, this is the string or buffer in which we - are matching. It is used for looking up syntax properties. */ -Lisp_Object re_match_object; -#endif - /* re_match_2 matches the compiled pattern in BUFP against the the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1 and SIZE2, respectively). We start matching at POS, and stop diff --git a/src/regex.h b/src/regex.h index 8fe7ba16adc..175eed10177 100644 --- a/src/regex.h +++ b/src/regex.h @@ -164,12 +164,12 @@ typedef unsigned long int reg_syntax_t; some interfaces). When a regexp is compiled, the syntax used is stored in the pattern buffer, so changing this does not affect already-compiled regexps. */ -extern reg_syntax_t re_syntax_options; +/* extern reg_syntax_t re_syntax_options; */ #ifdef emacs /* In Emacs, this is the string or buffer in which we are matching. It is used for looking up syntax properties. */ -extern Lisp_Object re_match_object; +/* extern Lisp_Object re_match_object; */ #endif diff --git a/src/search.c b/src/search.c index 8b4d39c7811..b4e3cca8269 100644 --- a/src/search.c +++ b/src/search.c @@ -42,7 +42,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ struct regexp_cache { struct regexp_cache *next; - Lisp_Object regexp, whitespace_regexp; + Lisp_Object regexp, f_whitespace_regexp; /* Syntax table for which the regexp applies. We need this because of character classes. If this is t, then the compiled pattern is valid for any syntax-table. */ @@ -77,12 +77,12 @@ static struct regexp_cache *searchbuf_head; to call re_set_registers after compiling a new pattern or after setting the match registers, so that the regex functions will be able to free or re-allocate it properly. */ -static struct re_registers search_regs; +/* static struct re_registers search_regs; */ /* The buffer in which the last search was performed, or Qt if the last search was done in a string; Qnil if no searching has been done yet. */ -static Lisp_Object last_thing_searched; +/* static Lisp_Object last_thing_searched; */ /* Error condition signaled when regexp compile_pattern fails. */ static Lisp_Object Qinvalid_regexp; @@ -130,9 +130,9 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern, cp->buf.multibyte = STRING_MULTIBYTE (pattern); cp->buf.charset_unibyte = charset_unibyte; if (STRINGP (Vsearch_spaces_regexp)) - cp->whitespace_regexp = Vsearch_spaces_regexp; + cp->f_whitespace_regexp = Vsearch_spaces_regexp; else - cp->whitespace_regexp = Qnil; + cp->f_whitespace_regexp = Qnil; /* rms: I think BLOCK_INPUT is not needed here any more, because regex.c defines malloc to call xmalloc. @@ -232,7 +232,7 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp, && cp->posix == posix && (EQ (cp->syntax_table, Qt) || EQ (cp->syntax_table, BVAR (current_buffer, syntax_table))) - && !NILP (Fequal (cp->whitespace_regexp, Vsearch_spaces_regexp)) + && !NILP (Fequal (cp->f_whitespace_regexp, Vsearch_spaces_regexp)) && cp->buf.charset_unibyte == charset_unibyte) break; @@ -2972,9 +2972,9 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */) /* If true the match data have been saved in saved_search_regs during the execution of a sentinel or filter. */ -static bool search_regs_saved; -static struct re_registers saved_search_regs; -static Lisp_Object saved_last_thing_searched; +/* static bool search_regs_saved; */ +/* static struct re_registers saved_search_regs; */ +/* static Lisp_Object saved_last_thing_searched; */ /* Called from Flooking_at, Fstring_match, search_buffer, Fstore_match_data if asynchronous code (filter or sentinel) is running. */ @@ -3078,10 +3078,10 @@ syms_of_search (void) searchbufs[i].buf.buffer = xmalloc (100); searchbufs[i].buf.fastmap = searchbufs[i].fastmap; searchbufs[i].regexp = Qnil; - searchbufs[i].whitespace_regexp = Qnil; + searchbufs[i].f_whitespace_regexp = Qnil; searchbufs[i].syntax_table = Qnil; staticpro (&searchbufs[i].regexp); - staticpro (&searchbufs[i].whitespace_regexp); + staticpro (&searchbufs[i].f_whitespace_regexp); staticpro (&searchbufs[i].syntax_table); searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]); } diff --git a/src/systhread.c b/src/systhread.c new file mode 100644 index 00000000000..ab647528452 --- /dev/null +++ b/src/systhread.c @@ -0,0 +1,131 @@ +/* System thread definitions + Copyright (C) 2012 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#include <config.h> +#include <setjmp.h> +#include "lisp.h" + +#ifdef HAVE_PTHREAD + +#include <sched.h> + +#ifdef HAVE_SYS_PRCTL_H +#include <sys/prctl.h> +#endif + +void +sys_mutex_init (sys_mutex_t *mutex) +{ + pthread_mutex_init (mutex, NULL); +} + +void +sys_mutex_lock (sys_mutex_t *mutex) +{ + pthread_mutex_lock (mutex); +} + +void +sys_mutex_unlock (sys_mutex_t *mutex) +{ + pthread_mutex_unlock (mutex); +} + +void +sys_mutex_destroy (sys_mutex_t *mutex) +{ + pthread_mutex_destroy (mutex); +} + +void +sys_cond_init (sys_cond_t *cond) +{ + pthread_cond_init (cond, NULL); +} + +void +sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex) +{ + pthread_cond_wait (cond, mutex); +} + +void +sys_cond_signal (sys_cond_t *cond) +{ + pthread_cond_signal (cond); +} + +void +sys_cond_broadcast (sys_cond_t *cond) +{ + pthread_cond_broadcast (cond); +} + +void +sys_cond_destroy (sys_cond_t *cond) +{ + pthread_cond_destroy (cond); +} + +sys_thread_t +sys_thread_self (void) +{ + return pthread_self (); +} + +int +sys_thread_equal (sys_thread_t one, sys_thread_t two) +{ + return pthread_equal (one, two); +} + +int +sys_thread_create (sys_thread_t *thread_ptr, const char *name, + thread_creation_function *func, void *arg) +{ + pthread_attr_t attr; + int result = 0; + + if (pthread_attr_init (&attr)) + return 0; + + if (!pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED)) + { + result = pthread_create (thread_ptr, &attr, func, arg) == 0; +#if defined (HAVE_SYS_PRCTL_H) && defined (HAVE_PRCTL) && defined (PR_SET_NAME) + if (result && name != NULL) + prctl (PR_SET_NAME, name); +#endif + } + + pthread_attr_destroy (&attr); + + return result; +} + +void +sys_thread_yield (void) +{ + sched_yield (); +} + +#else + +#error port me + +#endif diff --git a/src/systhread.h b/src/systhread.h new file mode 100644 index 00000000000..bbd242ab93c --- /dev/null +++ b/src/systhread.h @@ -0,0 +1,63 @@ +/* System thread definitions + Copyright (C) 2012 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#ifndef SYSTHREAD_H +#define SYSTHREAD_H + +#ifdef HAVE_PTHREAD + +#include <pthread.h> + +/* A system mutex is just a pthread mutex. This is only used for the + GIL. */ +typedef pthread_mutex_t sys_mutex_t; + +typedef pthread_cond_t sys_cond_t; + +/* A system thread. */ +typedef pthread_t sys_thread_t; + +#else + +#error port me + +#endif + +typedef void *(thread_creation_function) (void *); + +extern void sys_mutex_init (sys_mutex_t *); +extern void sys_mutex_lock (sys_mutex_t *); +extern void sys_mutex_unlock (sys_mutex_t *); +extern void sys_mutex_destroy (sys_mutex_t *); + +extern void sys_cond_init (sys_cond_t *); +extern void sys_cond_wait (sys_cond_t *, sys_mutex_t *); +extern void sys_cond_signal (sys_cond_t *); +extern void sys_cond_broadcast (sys_cond_t *); +extern void sys_cond_destroy (sys_cond_t *); + +extern sys_thread_t sys_thread_self (void); +extern int sys_thread_equal (sys_thread_t, sys_thread_t); + +extern int sys_thread_create (sys_thread_t *, const char *, + thread_creation_function *, + void *); + +extern void sys_thread_yield (void); + +#endif /* SYSTHREAD_H */ diff --git a/src/thread.c b/src/thread.c new file mode 100644 index 00000000000..1d282c3557a --- /dev/null +++ b/src/thread.c @@ -0,0 +1,955 @@ +/* Threading code. + Copyright (C) 2012, 2013 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + + +#include <config.h> +#include <setjmp.h> +#include "lisp.h" +#include "character.h" +#include "buffer.h" +#include "process.h" +#include "coding.h" + +static struct thread_state primary_thread; + +struct thread_state *current_thread = &primary_thread; + +static struct thread_state *all_threads = &primary_thread; + +static sys_mutex_t global_lock; + +Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep; + + + +static void +release_global_lock (void) +{ + sys_mutex_unlock (&global_lock); +} + +/* You must call this after acquiring the global lock. + acquire_global_lock does it for you. */ +static void +post_acquire_global_lock (struct thread_state *self) +{ + Lisp_Object buffer; + + if (self != current_thread) + { + unbind_for_thread_switch (); + current_thread = self; + rebind_for_thread_switch (); + } + + /* We need special handling to re-set the buffer. */ + XSETBUFFER (buffer, self->m_current_buffer); + self->m_current_buffer = 0; + set_buffer_internal (XBUFFER (buffer)); + + if (!NILP (current_thread->error_symbol)) + { + Lisp_Object sym = current_thread->error_symbol; + Lisp_Object data = current_thread->error_data; + + current_thread->error_symbol = Qnil; + current_thread->error_data = Qnil; + Fsignal (sym, data); + } +} + +static void +acquire_global_lock (struct thread_state *self) +{ + sys_mutex_lock (&global_lock); + post_acquire_global_lock (self); +} + + + +static void +lisp_mutex_init (lisp_mutex_t *mutex) +{ + mutex->owner = NULL; + mutex->count = 0; + sys_cond_init (&mutex->condition); +} + +static int +lisp_mutex_lock (lisp_mutex_t *mutex, int new_count) +{ + struct thread_state *self; + + if (mutex->owner == NULL) + { + mutex->owner = current_thread; + mutex->count = new_count == 0 ? 1 : new_count; + return 0; + } + if (mutex->owner == current_thread) + { + eassert (new_count == 0); + ++mutex->count; + return 0; + } + + self = current_thread; + self->wait_condvar = &mutex->condition; + while (mutex->owner != NULL && (new_count != 0 + || NILP (self->error_symbol))) + sys_cond_wait (&mutex->condition, &global_lock); + self->wait_condvar = NULL; + + if (new_count == 0 && !NILP (self->error_symbol)) + return 1; + + mutex->owner = self; + mutex->count = new_count == 0 ? 1 : new_count; + + return 1; +} + +static int +lisp_mutex_unlock (lisp_mutex_t *mutex) +{ + struct thread_state *self = current_thread; + + if (mutex->owner != current_thread) + error ("blah"); + + if (--mutex->count > 0) + return 0; + + mutex->owner = NULL; + sys_cond_broadcast (&mutex->condition); + + return 1; +} + +static unsigned int +lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex) +{ + struct thread_state *self = current_thread; + unsigned int result = mutex->count; + + /* Ensured by condvar code. */ + eassert (mutex->owner == current_thread); + + mutex->count = 0; + mutex->owner = NULL; + sys_cond_broadcast (&mutex->condition); + + return result; +} + +static void +lisp_mutex_destroy (lisp_mutex_t *mutex) +{ + sys_cond_destroy (&mutex->condition); +} + +static int +lisp_mutex_owned_p (lisp_mutex_t *mutex) +{ + return mutex->owner == current_thread; +} + + + +DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0, + doc: /* Create a mutex. +A mutex provides a synchronization point for threads. +Only one thread at a time can hold a mutex. Other threads attempting +to acquire it will block until the mutex is available. + +A thread can acquire a mutex any number of times. + +NAME, if given, is used as the name of the mutex. The name is +informational only. */) + (Lisp_Object name) +{ + struct Lisp_Mutex *mutex; + Lisp_Object result; + + if (!NILP (name)) + CHECK_STRING (name); + + mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX); + memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex), + 0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex, + mutex)); + mutex->name = name; + lisp_mutex_init (&mutex->mutex); + + XSETMUTEX (result, mutex); + return result; +} + +static void +mutex_lock_callback (void *arg) +{ + struct Lisp_Mutex *mutex = arg; + struct thread_state *self = current_thread; + + if (lisp_mutex_lock (&mutex->mutex, 0)) + post_acquire_global_lock (self); +} + +static Lisp_Object +do_unwind_mutex_lock (Lisp_Object ignore) +{ + current_thread->event_object = Qnil; + return Qnil; +} + +DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0, + doc: /* Acquire a mutex. +If the current thread already owns MUTEX, increment the count and +return. +Otherwise, if no thread owns MUTEX, make the current thread own it. +Otherwise, block until MUTEX is available, or until the current thread +is signalled using `thread-signal'. +Note that calls to `mutex-lock' and `mutex-unlock' must be paired. */) + (Lisp_Object mutex) +{ + struct Lisp_Mutex *lmutex; + ptrdiff_t count = SPECPDL_INDEX (); + + CHECK_MUTEX (mutex); + lmutex = XMUTEX (mutex); + + current_thread->event_object = mutex; + record_unwind_protect (do_unwind_mutex_lock, Qnil); + flush_stack_call_func (mutex_lock_callback, lmutex); + return unbind_to (count, Qnil); +} + +static void +mutex_unlock_callback (void *arg) +{ + struct Lisp_Mutex *mutex = arg; + struct thread_state *self = current_thread; + + if (lisp_mutex_unlock (&mutex->mutex)) + post_acquire_global_lock (self); +} + +DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0, + doc: /* Release the mutex. +If this thread does not own MUTEX, signal an error. +Otherwise, decrement the mutex's count. If the count is zero, +release MUTEX. */) + (Lisp_Object mutex) +{ + struct Lisp_Mutex *lmutex; + + CHECK_MUTEX (mutex); + lmutex = XMUTEX (mutex); + + flush_stack_call_func (mutex_unlock_callback, lmutex); + return Qnil; +} + +DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0, + doc: /* Return the name of MUTEX. +If no name was given when MUTEX was created, return nil. */) + (Lisp_Object mutex) +{ + struct Lisp_Mutex *lmutex; + + CHECK_MUTEX (mutex); + lmutex = XMUTEX (mutex); + + return lmutex->name; +} + +void +finalize_one_mutex (struct Lisp_Mutex *mutex) +{ + lisp_mutex_destroy (&mutex->mutex); +} + + + +DEFUN ("make-condition-variable", + Fmake_condition_variable, Smake_condition_variable, + 1, 2, 0, + doc: /* Make a condition variable. +A condition variable provides a way for a thread to sleep while +waiting for a state change. + +MUTEX is the mutex associated with this condition variable. +NAME, if given, is the name of this condition variable. The name is +informational only. */) + (Lisp_Object mutex, Lisp_Object name) +{ + struct Lisp_CondVar *condvar; + Lisp_Object result; + + CHECK_MUTEX (mutex); + if (!NILP (name)) + CHECK_STRING (name); + + condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR); + memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond), + 0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar, + cond)); + condvar->mutex = mutex; + condvar->name = name; + sys_cond_init (&condvar->cond); + + XSETCONDVAR (result, condvar); + return result; +} + +static void +condition_wait_callback (void *arg) +{ + struct Lisp_CondVar *cvar = arg; + struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex); + struct thread_state *self = current_thread; + unsigned int saved_count; + Lisp_Object cond; + + XSETCONDVAR (cond, cvar); + current_thread->event_object = cond; + saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex); + /* If we were signalled while unlocking, we skip the wait, but we + still must reacquire our lock. */ + if (NILP (self->error_symbol)) + { + self->wait_condvar = &cvar->cond; + sys_cond_wait (&cvar->cond, &global_lock); + self->wait_condvar = NULL; + } + lisp_mutex_lock (&mutex->mutex, saved_count); + current_thread->event_object = Qnil; + post_acquire_global_lock (self); +} + +DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0, + doc: /* Wait for the condition variable to be notified. +CONDITION is the condition variable to wait on. + +The mutex associated with CONDITION must be held when this is called. +It is an error if it is not held. + +This releases the mutex and waits for CONDITION to be notified or for +this thread to be signalled with `thread-signal'. When +`condition-wait' returns, the mutex will again be locked by this +thread. */) + (Lisp_Object condition) +{ + struct Lisp_CondVar *cvar; + struct Lisp_Mutex *mutex; + + CHECK_CONDVAR (condition); + cvar = XCONDVAR (condition); + + mutex = XMUTEX (cvar->mutex); + if (!lisp_mutex_owned_p (&mutex->mutex)) + error ("fixme"); + + flush_stack_call_func (condition_wait_callback, cvar); + + return Qnil; +} + +/* Used to communicate argumnets to condition_notify_callback. */ +struct notify_args +{ + struct Lisp_CondVar *cvar; + int all; +}; + +static void +condition_notify_callback (void *arg) +{ + struct notify_args *na = arg; + struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex); + struct thread_state *self = current_thread; + unsigned int saved_count; + Lisp_Object cond; + + XSETCONDVAR (cond, na->cvar); + saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex); + if (na->all) + sys_cond_broadcast (&na->cvar->cond); + else + sys_cond_signal (&na->cvar->cond); + lisp_mutex_lock (&mutex->mutex, saved_count); + post_acquire_global_lock (self); +} + +DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0, + doc: /* Notify a condition variable. +This wakes a thread waiting on CONDITION. +If ALL is non-nil, all waiting threads are awoken. + +The mutex associated with CONDITION must be held when this is called. +It is an error if it is not held. + +This releases the mutex when notifying CONDITION. When +`condition-notify' returns, the mutex will again be locked by this +thread. */) + (Lisp_Object condition, Lisp_Object all) +{ + struct Lisp_CondVar *cvar; + struct Lisp_Mutex *mutex; + struct notify_args args; + + CHECK_CONDVAR (condition); + cvar = XCONDVAR (condition); + + mutex = XMUTEX (cvar->mutex); + if (!lisp_mutex_owned_p (&mutex->mutex)) + error ("fixme"); + + args.cvar = cvar; + args.all = !NILP (all); + flush_stack_call_func (condition_notify_callback, &args); + + return Qnil; +} + +DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0, + doc: /* Return the mutex associated with CONDITION. */) + (Lisp_Object condition) +{ + struct Lisp_CondVar *cvar; + + CHECK_CONDVAR (condition); + cvar = XCONDVAR (condition); + + return cvar->mutex; +} + +DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0, + doc: /* Return the name of CONDITION. +If no name was given when CONDITION was created, return nil. */) + (Lisp_Object condition) +{ + struct Lisp_CondVar *cvar; + + CHECK_CONDVAR (condition); + cvar = XCONDVAR (condition); + + return cvar->name; +} + +void +finalize_one_condvar (struct Lisp_CondVar *condvar) +{ + sys_cond_destroy (&condvar->cond); +} + + + +struct select_args +{ + select_func *func; + int max_fds; + SELECT_TYPE *rfds; + SELECT_TYPE *wfds; + SELECT_TYPE *efds; + EMACS_TIME *timeout; + sigset_t *sigmask; + int result; +}; + +static void +really_call_select (void *arg) +{ + struct select_args *sa = arg; + struct thread_state *self = current_thread; + + release_global_lock (); + sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds, + sa->timeout, sa->sigmask); + acquire_global_lock (self); +} + +int +thread_select (select_func *func, int max_fds, SELECT_TYPE *rfds, + SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *timeout, + sigset_t *sigmask) +{ + struct select_args sa; + + sa.func = func; + sa.max_fds = max_fds; + sa.rfds = rfds; + sa.wfds = wfds; + sa.efds = efds; + sa.timeout = timeout; + sa.sigmask = sigmask; + flush_stack_call_func (really_call_select, &sa); + return sa.result; +} + + + +static void +mark_one_thread (struct thread_state *thread) +{ + struct handler *handler; + Lisp_Object tem; + + mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr); + +#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ + || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) + mark_stack (thread->m_stack_bottom, thread->stack_top); +#else + { + struct gcpro *tail; + for (tail = thread->m_gcprolist; tail; tail = tail->next) + for (i = 0; i < tail->nvars; i++) + mark_object (tail->var[i]); + } + +#if BYTE_MARK_STACK + if (thread->m_byte_stack_list) + mark_byte_stack (thread->m_byte_stack_list); +#endif + + mark_catchlist (thread->m_catchlist); + + for (handler = thread->m_handlerlist; handler; handler = handler->next) + { + mark_object (handler->handler); + mark_object (handler->var); + } +#endif + + if (thread->m_current_buffer) + { + XSETBUFFER (tem, thread->m_current_buffer); + mark_object (tem); + } + + mark_object (thread->m_last_thing_searched); + + if (thread->m_saved_last_thing_searched) + mark_object (thread->m_saved_last_thing_searched); +} + +static void +mark_threads_callback (void *ignore) +{ + struct thread_state *iter; + + for (iter = all_threads; iter; iter = iter->next_thread) + { + Lisp_Object thread_obj; + + XSETTHREAD (thread_obj, iter); + mark_object (thread_obj); + mark_one_thread (iter); + } +} + +void +mark_threads (void) +{ + flush_stack_call_func (mark_threads_callback, NULL); +} + +void +unmark_threads (void) +{ + struct thread_state *iter; + + for (iter = all_threads; iter; iter = iter->next_thread) + if (iter->m_byte_stack_list) + unmark_byte_stack (iter->m_byte_stack_list); +} + + + +static void +yield_callback (void *ignore) +{ + struct thread_state *self = current_thread; + + release_global_lock (); + sys_thread_yield (); + acquire_global_lock (self); +} + +DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0, + doc: /* Yield the CPU to another thread. */) + (void) +{ + flush_stack_call_func (yield_callback, NULL); + return Qnil; +} + +static Lisp_Object +invoke_thread_function (void) +{ + Lisp_Object iter; + + int count = SPECPDL_INDEX (); + + Ffuncall (1, ¤t_thread->function); + return unbind_to (count, Qnil); +} + +static Lisp_Object +do_nothing (Lisp_Object whatever) +{ + return whatever; +} + +static void * +run_thread (void *state) +{ + char stack_pos; + struct thread_state *self = state; + struct thread_state **iter; + + self->m_stack_bottom = &stack_pos; + self->stack_top = self->m_stack_bottom = &stack_pos; + self->thread_id = sys_thread_self (); + + acquire_global_lock (self); + + /* It might be nice to do something with errors here. */ + internal_condition_case (invoke_thread_function, Qt, do_nothing); + + unbind_for_thread_switch (); + + update_processes_for_thread_death (Fcurrent_thread ()); + + /* Unlink this thread from the list of all threads. */ + for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread) + ; + *iter = (*iter)->next_thread; + + self->m_last_thing_searched = Qnil; + self->m_saved_last_thing_searched = Qnil; + self->name = Qnil; + self->function = Qnil; + self->error_symbol = Qnil; + self->error_data = Qnil; + xfree (self->m_specpdl); + self->m_specpdl = NULL; + self->m_specpdl_ptr = NULL; + self->m_specpdl_size = 0; + + sys_cond_broadcast (&self->thread_condvar); + + release_global_lock (); + + return NULL; +} + +void +finalize_one_thread (struct thread_state *state) +{ + sys_cond_destroy (&state->thread_condvar); +} + +DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0, + doc: /* Start a new thread and run FUNCTION in it. +When the function exits, the thread dies. +If NAME is given, it names the new thread. */) + (Lisp_Object function, Lisp_Object name) +{ + sys_thread_t thr; + struct thread_state *new_thread; + Lisp_Object result; + const char *c_name = NULL; + + /* Can't start a thread in temacs. */ + if (!initialized) + abort (); + + if (!NILP (name)) + CHECK_STRING (name); + + new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_gcprolist, + PVEC_THREAD); + memset ((char *) new_thread + offsetof (struct thread_state, m_gcprolist), + 0, sizeof (struct thread_state) - offsetof (struct thread_state, + m_gcprolist)); + + new_thread->function = function; + new_thread->name = name; + new_thread->m_last_thing_searched = Qnil; /* copy from parent? */ + new_thread->m_saved_last_thing_searched = Qnil; + new_thread->m_current_buffer = current_thread->m_current_buffer; + new_thread->error_symbol = Qnil; + new_thread->error_data = Qnil; + new_thread->event_object = Qnil; + + new_thread->m_specpdl_size = 50; + new_thread->m_specpdl = xmalloc (new_thread->m_specpdl_size + * sizeof (struct specbinding)); + new_thread->m_specpdl_ptr = new_thread->m_specpdl; + + sys_cond_init (&new_thread->thread_condvar); + + /* We'll need locking here eventually. */ + new_thread->next_thread = all_threads; + all_threads = new_thread; + + if (!NILP (name)) + c_name = SSDATA (ENCODE_UTF_8 (name)); + + if (! sys_thread_create (&thr, c_name, run_thread, new_thread)) + { + /* Restore the previous situation. */ + all_threads = all_threads->next_thread; + error ("Could not start a new thread"); + } + + /* FIXME: race here where new thread might not be filled in? */ + XSETTHREAD (result, new_thread); + return result; +} + +DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0, + doc: /* Return the current thread. */) + (void) +{ + Lisp_Object result; + XSETTHREAD (result, current_thread); + return result; +} + +DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0, + doc: /* Return the name of the THREAD. +The name is the same object that was passed to `make-thread'. */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + return tstate->name; +} + +static void +thread_signal_callback (void *arg) +{ + struct thread_state *tstate = arg; + struct thread_state *self = current_thread; + + sys_cond_broadcast (tstate->wait_condvar); + post_acquire_global_lock (self); +} + +DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0, + doc: /* Signal an error in a thread. +This acts like `signal', but arranges for the signal to be raised +in THREAD. If THREAD is the current thread, acts just like `signal'. +This will interrupt a blocked call to `mutex-lock', `condition-wait', +or `thread-join' in the target thread. */) + (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + if (tstate == current_thread) + Fsignal (error_symbol, data); + + /* What to do if thread is already signalled? */ + /* What if error_symbol is Qnil? */ + tstate->error_symbol = error_symbol; + tstate->error_data = data; + + if (tstate->wait_condvar) + flush_stack_call_func (thread_signal_callback, tstate); + + return Qnil; +} + +DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0, + doc: /* Return t if THREAD is alive, or nil if it has exited. */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + /* m_specpdl is set when the thread is created and cleared when the + thread dies. */ + return tstate->m_specpdl == NULL ? Qnil : Qt; +} + +DEFUN ("thread-blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0, + doc: /* Return the object that THREAD is blocking on. +If THREAD is blocked in `thread-join' on a second thread, return that +thread. +If THREAD is blocked in `mutex-lock', return the mutex. +If THREAD is blocked in `condition-wait', return the condition variable. +Otherwise, if THREAD is not blocked, return nil. */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + return tstate->event_object; +} + +static void +thread_join_callback (void *arg) +{ + struct thread_state *tstate = arg; + struct thread_state *self = current_thread; + Lisp_Object thread; + + XSETTHREAD (thread, tstate); + self->event_object = thread; + self->wait_condvar = &tstate->thread_condvar; + while (tstate->m_specpdl != NULL && NILP (self->error_symbol)) + sys_cond_wait (self->wait_condvar, &global_lock); + + self->wait_condvar = NULL; + self->event_object = Qnil; + post_acquire_global_lock (self); +} + +DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0, + doc: /* Wait for a thread to exit. +This blocks the current thread until THREAD exits. +It is an error for a thread to try to join itself. */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + if (tstate == current_thread) + error ("cannot join current thread"); + + if (tstate->m_specpdl != NULL) + flush_stack_call_func (thread_join_callback, tstate); + + return Qnil; +} + +DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0, + doc: /* Return a list of all threads. */) + (void) +{ + Lisp_Object result = Qnil; + struct thread_state *iter; + + for (iter = all_threads; iter; iter = iter->next_thread) + { + Lisp_Object thread; + + XSETTHREAD (thread, iter); + result = Fcons (thread, result); + } + + return result; +} + + + +int +thread_check_current_buffer (struct buffer *buffer) +{ + struct thread_state *iter; + + for (iter = all_threads; iter; iter = iter->next_thread) + { + if (iter == current_thread) + continue; + + if (iter->m_current_buffer == buffer) + return 1; + } + + return 0; +} + + + +static void +init_primary_thread (void) +{ + primary_thread.header.size + = PSEUDOVECSIZE (struct thread_state, m_gcprolist); + XSETPVECTYPE (&primary_thread, PVEC_THREAD); + primary_thread.m_last_thing_searched = Qnil; + primary_thread.m_saved_last_thing_searched = Qnil; + primary_thread.name = Qnil; + primary_thread.function = Qnil; + primary_thread.error_symbol = Qnil; + primary_thread.error_data = Qnil; + primary_thread.event_object = Qnil; + + sys_cond_init (&primary_thread.thread_condvar); +} + +void +init_threads_once (void) +{ + init_primary_thread (); +} + +void +init_threads (void) +{ + init_primary_thread (); + + sys_mutex_init (&global_lock); + sys_mutex_lock (&global_lock); +} + +void +syms_of_threads (void) +{ + defsubr (&Sthread_yield); + defsubr (&Smake_thread); + defsubr (&Scurrent_thread); + defsubr (&Sthread_name); + defsubr (&Sthread_signal); + defsubr (&Sthread_alive_p); + defsubr (&Sthread_join); + defsubr (&Sthread_blocker); + defsubr (&Sall_threads); + defsubr (&Smake_mutex); + defsubr (&Smutex_lock); + defsubr (&Smutex_unlock); + defsubr (&Smutex_name); + defsubr (&Smake_condition_variable); + defsubr (&Scondition_wait); + defsubr (&Scondition_notify); + defsubr (&Scondition_mutex); + defsubr (&Scondition_name); + + Qthreadp = intern_c_string ("threadp"); + staticpro (&Qthreadp); + Qmutexp = intern_c_string ("mutexp"); + staticpro (&Qmutexp); + Qcondition_variablep = intern_c_string ("condition-variablep"); + staticpro (&Qcondition_variablep); +} diff --git a/src/thread.h b/src/thread.h new file mode 100644 index 00000000000..9f0eead4637 --- /dev/null +++ b/src/thread.h @@ -0,0 +1,250 @@ +/* Thread definitions + Copyright (C) 2012, 2013 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#ifndef THREAD_H +#define THREAD_H + +#include "regex.h" + +#include "sysselect.h" /* FIXME */ +#include "systime.h" /* FIXME */ + +struct thread_state +{ + struct vectorlike_header header; + + /* The buffer in which the last search was performed, or + Qt if the last search was done in a string; + Qnil if no searching has been done yet. */ + Lisp_Object m_last_thing_searched; +#define last_thing_searched (current_thread->m_last_thing_searched) + + Lisp_Object m_saved_last_thing_searched; +#define saved_last_thing_searched (current_thread->m_saved_last_thing_searched) + + /* The thread's name. */ + Lisp_Object name; + + /* The thread's function. */ + Lisp_Object function; + + /* If non-nil, this thread has been signalled. */ + Lisp_Object error_symbol; + Lisp_Object error_data; + + /* If we are waiting for some event, this holds the object we are + waiting on. */ + Lisp_Object event_object; + + /* m_gcprolist must be the first non-lisp field. */ + /* Recording what needs to be marked for gc. */ + struct gcpro *m_gcprolist; +#define gcprolist (current_thread->m_gcprolist) + + /* A list of currently active byte-code execution value stacks. + Fbyte_code adds an entry to the head of this list before it starts + processing byte-code, and it removed the entry again when it is + done. Signalling an error truncates the list analoguous to + gcprolist. */ + struct byte_stack *m_byte_stack_list; +#define byte_stack_list (current_thread->m_byte_stack_list) + + /* An address near the bottom of the stack. + Tells GC how to save a copy of the stack. */ + char *m_stack_bottom; +#define stack_bottom (current_thread->m_stack_bottom) + + /* An address near the top of the stack. */ + char *stack_top; + + struct catchtag *m_catchlist; +#define catchlist (current_thread->m_catchlist) + + /* Chain of condition handlers currently in effect. + The elements of this chain are contained in the stack frames + of Fcondition_case and internal_condition_case. + When an error is signaled (by calling Fsignal, below), + this chain is searched for an element that applies. */ + struct handler *m_handlerlist; +#define handlerlist (current_thread->m_handlerlist) + + /* Count levels of GCPRO to detect failure to UNGCPRO. */ + int m_gcpro_level; +#define gcpro_level (current_thread->m_gcpro_level) + + /* Current number of specbindings allocated in specpdl. */ + ptrdiff_t m_specpdl_size; +#define specpdl_size (current_thread->m_specpdl_size) + + /* Pointer to beginning of specpdl. */ + struct specbinding *m_specpdl; +#define specpdl (current_thread->m_specpdl) + + /* Pointer to first unused element in specpdl. */ + struct specbinding *m_specpdl_ptr; +#define specpdl_ptr (current_thread->m_specpdl_ptr) + + /* Pointer to the first "saved" element in specpdl. When this + thread is swapped out, the current values of all specpdl bindings + are pushed onto the specpdl; then these are popped again when + switching back to this thread. */ + struct specbinding *m_saved_specpdl_ptr; + + /* Depth in Lisp evaluations and function calls. */ + EMACS_INT m_lisp_eval_depth; +#define lisp_eval_depth (current_thread->m_lisp_eval_depth) + + /* This points to the current buffer. */ + struct buffer *m_current_buffer; +#define current_buffer (current_thread->m_current_buffer) + + /* Every call to re_match, etc., must pass &search_regs as the regs + argument unless you can show it is unnecessary (i.e., if re_match + is certainly going to be called again before region-around-match + can be called). + + Since the registers are now dynamically allocated, we need to make + sure not to refer to the Nth register before checking that it has + been allocated by checking search_regs.num_regs. + + The regex code keeps track of whether it has allocated the search + buffer using bits in the re_pattern_buffer. This means that whenever + you compile a new pattern, it completely forgets whether it has + allocated any registers, and will allocate new registers the next + time you call a searching or matching function. Therefore, we need + to call re_set_registers after compiling a new pattern or after + setting the match registers, so that the regex functions will be + able to free or re-allocate it properly. */ + struct re_registers m_search_regs; +#define search_regs (current_thread->m_search_regs) + + /* If non-zero the match data have been saved in saved_search_regs + during the execution of a sentinel or filter. */ + bool m_search_regs_saved; +#define search_regs_saved (current_thread->m_search_regs_saved) + + struct re_registers m_saved_search_regs; +#define saved_search_regs (current_thread->m_saved_search_regs) + + /* This is the string or buffer in which we + are matching. It is used for looking up syntax properties. */ + Lisp_Object m_re_match_object; +#define re_match_object (current_thread->m_re_match_object) + + /* Set by `re_set_syntax' to the current regexp syntax to recognize. Can + also be assigned to arbitrarily: each pattern buffer stores its own + syntax, so it can be changed between regex compilations. */ + reg_syntax_t m_re_syntax_options; +#define re_syntax_options (current_thread->m_re_syntax_options) + + /* Regexp to use to replace spaces, or NULL meaning don't. */ + /*re_char*/ unsigned char *m_whitespace_regexp; +#define whitespace_regexp (current_thread->m_whitespace_regexp) + + /* This variable is different from waiting_for_input in keyboard.c. + It is used to communicate to a lisp process-filter/sentinel (via the + function Fwaiting_for_user_input_p) whether Emacs was waiting + for user-input when that process-filter was called. + waiting_for_input cannot be used as that is by definition 0 when + lisp code is being evalled. + This is also used in record_asynch_buffer_change. + For that purpose, this must be 0 + when not inside wait_reading_process_output. */ + int m_waiting_for_user_input_p; +#define waiting_for_user_input_p (current_thread->m_waiting_for_user_input_p) + + /* The OS identifier for this thread. */ + sys_thread_t thread_id; + + /* The condition variable for this thread. This is associated with + the global lock. This thread broadcasts to it when it exits. */ + sys_cond_t thread_condvar; + + /* This thread might be waiting for some condition. If so, this + points to the condition. If the thread is interrupted, the + interrupter should broadcast to this condition. */ + sys_cond_t *wait_condvar; + + /* Threads are kept on a linked list. */ + struct thread_state *next_thread; +}; + +/* A mutex in lisp is represented by a system condition variable. + The system mutex associated with this condition variable is the + global lock. + + Using a condition variable lets us implement interruptibility for + lisp mutexes. */ +typedef struct +{ + /* The owning thread, or NULL if unlocked. */ + struct thread_state *owner; + /* The lock count. */ + unsigned int count; + /* The underlying system condition variable. */ + sys_cond_t condition; +} lisp_mutex_t; + +/* A mutex as a lisp object. */ +struct Lisp_Mutex +{ + struct vectorlike_header header; + + /* The name of the mutex, or nil. */ + Lisp_Object name; + + /* The lower-level mutex object. */ + lisp_mutex_t mutex; +}; + +/* A condition variable as a lisp object. */ +struct Lisp_CondVar +{ + struct vectorlike_header header; + + /* The associated mutex. */ + Lisp_Object mutex; + + /* The name of the condition variable, or nil. */ + Lisp_Object name; + + /* The lower-level condition variable object. */ + sys_cond_t cond; +}; + +extern struct thread_state *current_thread; + +extern void unmark_threads (void); +extern void finalize_one_thread (struct thread_state *state); +extern void finalize_one_mutex (struct Lisp_Mutex *); +extern void finalize_one_condvar (struct Lisp_CondVar *); + +extern void init_threads_once (void); +extern void init_threads (void); +extern void syms_of_threads (void); + +typedef int select_func (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, + EMACS_TIME *, sigset_t *); + +int thread_select (select_func *func, int max_fds, SELECT_TYPE *rfds, + SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *timeout, + sigset_t *sigmask); + +int thread_check_current_buffer (struct buffer *); + +#endif /* THREAD_H */ diff --git a/src/window.c b/src/window.c index 7cf35a480f7..33bf70b75c8 100644 --- a/src/window.c +++ b/src/window.c @@ -5433,7 +5433,7 @@ struct save_window_data struct vectorlike_header header; Lisp_Object selected_frame; Lisp_Object current_window; - Lisp_Object current_buffer; + Lisp_Object f_current_buffer; Lisp_Object minibuf_scroll_window; Lisp_Object minibuf_selected_window; Lisp_Object root_window; @@ -5513,7 +5513,7 @@ the return value is nil. Otherwise the value is t. */) data = (struct save_window_data *) XVECTOR (configuration); saved_windows = XVECTOR (data->saved_windows); - new_current_buffer = data->current_buffer; + new_current_buffer = data->f_current_buffer; if (!BUFFER_LIVE_P (XBUFFER (new_current_buffer))) new_current_buffer = Qnil; else @@ -6122,7 +6122,7 @@ saved by this function. */) data->frame_tool_bar_lines = FRAME_TOOL_BAR_LINES (f); data->selected_frame = selected_frame; data->current_window = FRAME_SELECTED_WINDOW (f); - XSETBUFFER (data->current_buffer, current_buffer); + XSETBUFFER (data->f_current_buffer, current_buffer); data->minibuf_scroll_window = minibuf_level > 0 ? Vminibuf_scroll_window : Qnil; data->minibuf_selected_window = minibuf_level > 0 ? minibuf_selected_window : Qnil; data->root_window = FRAME_ROOT_WINDOW (f); @@ -6516,7 +6516,7 @@ compare_window_configurations (Lisp_Object configuration1, || d1->frame_lines != d2->frame_lines || d1->frame_menu_bar_lines != d2->frame_menu_bar_lines || !EQ (d1->selected_frame, d2->selected_frame) - || !EQ (d1->current_buffer, d2->current_buffer) + || !EQ (d1->f_current_buffer, d2->f_current_buffer) || (!ignore_positions && (!EQ (d1->minibuf_scroll_window, d2->minibuf_scroll_window) || !EQ (d1->minibuf_selected_window, d2->minibuf_selected_window))) |