aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authorEli Zaretskii2016-12-10 18:54:43 +0200
committerEli Zaretskii2016-12-10 18:54:43 +0200
commit2412a1fc05fe9f89b171d0781c2d530923f48adc (patch)
treed42a5d2608e65a10b1cc23c6b4609d54bef25d49 /src
parentfc0fd24c105bde4c001ebebe4b8b7e1f96cd2871 (diff)
parent828b4560cd4a0d8cb9b7a7a3e20ff0c53ba86cfa (diff)
downloademacs-2412a1fc05fe9f89b171d0781c2d530923f48adc.tar.gz
emacs-2412a1fc05fe9f89b171d0781c2d530923f48adc.zip
Support concurrency in Emacs Lisp
Merge branch 'test-concurrency' * src/thread.c: * src/thread.h: * src/systhread.c: * src/systhread.h: New files. * src/xgselect.c (xg_select): Avoid using SAFE_NALLOCA and use xnmalloc unconditionally. * src/window.c (struct save_window_data): Rename current_buffer to f_current_buffer. * src/w32proc.c (sys_select): Change the function signature to closer fit 'pselect' on Posix hosts. * src/search.c: * src/regex.h: Convert some globals to macros that reference thread-specific values. * src/process.c (pset_thread, add_non_keyboard_read_fd) (add_process_read_fd, add_non_blocking_write_fd) (recompute_input_desc, compute_input_wait_mask) (compute_non_process_wait_mask, compute_non_keyboard_wait_mask) (compute_write_mask, clear_waiting_thread_info) (update_processes_for_thread_death, Fset_process_thread) (Fprocess_thread): New functions. (enum fd_bits): New enumeration. (fd_callback_data): Add 'thread' and 'waiting_thread', rename 'condition' to 'flags'. (set_process_filter_masks, create_process, create_pty) (Fmake_serial_process, finish_after_tls_connection) (connect_network_socket, deactivate_process) (server_accept_connection, wait_reading_process_output) (Fcontinue_process, Fstop_process, keyboard_bit_set) (add_timer_wait_descriptor, add_keyboard_wait_descriptor) (delete_keyboard_wait_descriptor): Use the new functions instead of manipulating fd flags and masks directly. (syms_of_process): Defsubr the new primitives. * src/print.c (print_object): Print threads, mutexes, and conditional variables. * src/lisp.h (enum pvec_type): New values PVEC_THREAD, PVEC_MUTEX, and PVEC_CONDVAR. (XTHREAD, XMUTEX, XCONDVAR, THREADP, MUTEXP, CONDVARP) (CHECK_THREAD, CHECK_MUTEX, CHECK_CONDVAR): New inline functions. (XSETTHREAD, XSETMUTEX, XSETCONDVAR): New macros. (struct handler): Add back byte_stack. Rename lisp_eval_depth to f_lisp_eval_depth. * src/eval.c (specpdl_kind, specpdl_arg, do_specbind) (rebind_for_thread_switch, do_one_unbind) (unbind_for_thread_switch): New functions. (init_eval): 'handlerlist' is not malloc'ed. (specbind): Call do_specbind. (unbind_to): Call do_one_unbind. (mark_specpdl): Accept 2 arguments. (mark_specpdl): Mark the saved value in a let-binding. * src/emacs.c (main): Call init_threads_once, init_threads, and syms_of_threads. * src/data.c (Ftype_of): Support thread, mutex, and condvar objects. (Fthreadp, Fmutexp, Fcondition_variable_p): New functions. (syms_of_data): DEFSYM and defsubr new symbols and primitives. * src/bytecode.c (struct byte_stack, FETCH, CHECK_RANGE) (BYTE_CODE_QUIT): Add back. (exec_byte_code): Add back byte stack manipulation. * src/alloc.c (cleanup_vector): Handle threads, mutexes, and conditional variables. (mark_stack): Now extern; accept additional argument 'bottom'. (flush_stack_call_func): New function. (garbage_collect_1): Call mark_threads and unmark_threads. Don't mark handlers. * src/.gdbinit (xbytecode): Add back. * test/src/thread-tests.el: New tests. * test/src/data-tests.el (binding-test-manual) (binding-test-setq-default, binding-test-makunbound) (binding-test-defvar-bool, binding-test-defvar-int) (binding-test-set-constant-t, binding-test-set-constant-nil) (binding-test-set-constant-keyword) (binding-test-set-constant-nil): New tests. * doc/lispref/processes.texi (Processes and Threads): New subsection. * doc/lispref/threads.texi: New file * doc/lispref/elisp.texi (Top): Include it. * doc/lispref/objects.texi (Thread Type, Mutex Type) (Condition Variable Type): New subsections. (Type Predicates): Add thread-related predicates. * doc/lispref/objects.texi (Editing Types): * doc/lispref/elisp.texi (Top): Update higher-level menus. * etc/NEWS: Mention concurrency features.
Diffstat (limited to 'src')
-rw-r--r--src/.gdbinit15
-rw-r--r--src/Makefile.in1
-rw-r--r--src/alloc.c110
-rw-r--r--src/buffer.c5
-rw-r--r--src/buffer.h4
-rw-r--r--src/bytecode.c203
-rw-r--r--src/data.c39
-rw-r--r--src/emacs.c14
-rw-r--r--src/eval.c268
-rw-r--r--src/lisp.h162
-rw-r--r--src/print.c36
-rw-r--r--src/process.c547
-rw-r--r--src/process.h5
-rw-r--r--src/regex.c6
-rw-r--r--src/regex.h8
-rw-r--r--src/search.c22
-rw-r--r--src/sysdep.c9
-rw-r--r--src/systhread.c417
-rw-r--r--src/systhread.h112
-rw-r--r--src/thread.c970
-rw-r--r--src/thread.h237
-rw-r--r--src/w32.c2
-rw-r--r--src/w32proc.c8
-rw-r--r--src/window.c8
-rw-r--r--src/xgselect.c12
25 files changed, 2776 insertions, 444 deletions
diff --git a/src/.gdbinit b/src/.gdbinit
index b0c0dfd7e90..9160ffa439e 100644
--- a/src/.gdbinit
+++ b/src/.gdbinit
@@ -1215,6 +1215,21 @@ document xwhichsymbols
1215 maximum number of symbols referencing it to produce. 1215 maximum number of symbols referencing it to produce.
1216end 1216end
1217 1217
1218define xbytecode
1219 set $bt = byte_stack_list
1220 while $bt
1221 xgetptr $bt->byte_string
1222 set $ptr = (struct Lisp_String *) $ptr
1223 xprintbytestr $ptr
1224 printf "\n0x%x => ", $bt->byte_string
1225 xwhichsymbols $bt->byte_string 5
1226 set $bt = $bt->next
1227 end
1228end
1229document xbytecode
1230 Print a backtrace of the byte code stack.
1231end
1232
1218# Show Lisp backtrace after normal backtrace. 1233# Show Lisp backtrace after normal backtrace.
1219define hookpost-backtrace 1234define hookpost-backtrace
1220 set $bt = backtrace_top () 1235 set $bt = backtrace_top ()
diff --git a/src/Makefile.in b/src/Makefile.in
index 7ca147f1eb5..ffc741d48d3 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -409,6 +409,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
409 doprnt.o intervals.o textprop.o composite.o xml.o $(NOTIFY_OBJ) \ 409 doprnt.o intervals.o textprop.o composite.o xml.o $(NOTIFY_OBJ) \
410 $(XWIDGETS_OBJ) \ 410 $(XWIDGETS_OBJ) \
411 profiler.o decompress.o \ 411 profiler.o decompress.o \
412 thread.o systhread.o \
412 $(if $(HYBRID_MALLOC),sheap.o) \ 413 $(if $(HYBRID_MALLOC),sheap.o) \
413 $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ 414 $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
414 $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) 415 $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ)
diff --git a/src/alloc.c b/src/alloc.c
index 6eced7bab18..f2b7682b05d 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -438,10 +438,6 @@ struct mem_node
438 enum mem_type type; 438 enum mem_type type;
439}; 439};
440 440
441/* Base address of stack. Set in main. */
442
443Lisp_Object *stack_base;
444
445/* Root of the tree describing allocated Lisp memory. */ 441/* Root of the tree describing allocated Lisp memory. */
446 442
447static struct mem_node *mem_root; 443static struct mem_node *mem_root;
@@ -3190,8 +3186,7 @@ vector_nbytes (struct Lisp_Vector *v)
3190} 3186}
3191 3187
3192/* Release extra resources still in use by VECTOR, which may be any 3188/* Release extra resources still in use by VECTOR, which may be any
3193 vector-like object. For now, this is used just to free data in 3189 vector-like object. */
3194 font objects. */
3195 3190
3196static void 3191static void
3197cleanup_vector (struct Lisp_Vector *vector) 3192cleanup_vector (struct Lisp_Vector *vector)
@@ -3212,6 +3207,13 @@ cleanup_vector (struct Lisp_Vector *vector)
3212 drv->close ((struct font *) vector); 3207 drv->close ((struct font *) vector);
3213 } 3208 }
3214 } 3209 }
3210
3211 if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
3212 finalize_one_thread ((struct thread_state *) vector);
3213 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
3214 finalize_one_mutex ((struct Lisp_Mutex *) vector);
3215 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
3216 finalize_one_condvar ((struct Lisp_CondVar *) vector);
3215} 3217}
3216 3218
3217/* Reclaim space used by unmarked vectors. */ 3219/* Reclaim space used by unmarked vectors. */
@@ -5047,14 +5049,13 @@ test_setjmp (void)
5047 would be necessary, each one starting with one byte more offset 5049 would be necessary, each one starting with one byte more offset
5048 from the stack start. */ 5050 from the stack start. */
5049 5051
5050static void 5052void
5051mark_stack (void *end) 5053mark_stack (char *bottom, char *end)
5052{ 5054{
5053
5054 /* This assumes that the stack is a contiguous region in memory. If 5055 /* This assumes that the stack is a contiguous region in memory. If
5055 that's not the case, something has to be done here to iterate 5056 that's not the case, something has to be done here to iterate
5056 over the stack segments. */ 5057 over the stack segments. */
5057 mark_memory (stack_base, end); 5058 mark_memory (bottom, end);
5058 5059
5059 /* Allow for marking a secondary stack, like the register stack on the 5060 /* Allow for marking a secondary stack, like the register stack on the
5060 ia64. */ 5061 ia64. */
@@ -5063,6 +5064,81 @@ mark_stack (void *end)
5063#endif 5064#endif
5064} 5065}
5065 5066
5067/* This is a trampoline function that flushes registers to the stack,
5068 and then calls FUNC. ARG is passed through to FUNC verbatim.
5069
5070 This function must be called whenever Emacs is about to release the
5071 global interpreter lock. This lets the garbage collector easily
5072 find roots in registers on threads that are not actively running
5073 Lisp.
5074
5075 It is invalid to run any Lisp code or to allocate any GC memory
5076 from FUNC. */
5077
5078void
5079flush_stack_call_func (void (*func) (void *arg), void *arg)
5080{
5081 void *end;
5082 struct thread_state *self = current_thread;
5083
5084#ifdef HAVE___BUILTIN_UNWIND_INIT
5085 /* Force callee-saved registers and register windows onto the stack.
5086 This is the preferred method if available, obviating the need for
5087 machine dependent methods. */
5088 __builtin_unwind_init ();
5089 end = &end;
5090#else /* not HAVE___BUILTIN_UNWIND_INIT */
5091#ifndef GC_SAVE_REGISTERS_ON_STACK
5092 /* jmp_buf may not be aligned enough on darwin-ppc64 */
5093 union aligned_jmpbuf {
5094 Lisp_Object o;
5095 sys_jmp_buf j;
5096 } j;
5097 volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom;
5098#endif
5099 /* This trick flushes the register windows so that all the state of
5100 the process is contained in the stack. */
5101 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
5102 needed on ia64 too. See mach_dep.c, where it also says inline
5103 assembler doesn't work with relevant proprietary compilers. */
5104#ifdef __sparc__
5105#if defined (__sparc64__) && defined (__FreeBSD__)
5106 /* FreeBSD does not have a ta 3 handler. */
5107 asm ("flushw");
5108#else
5109 asm ("ta 3");
5110#endif
5111#endif
5112
5113 /* Save registers that we need to see on the stack. We need to see
5114 registers used to hold register variables and registers used to
5115 pass parameters. */
5116#ifdef GC_SAVE_REGISTERS_ON_STACK
5117 GC_SAVE_REGISTERS_ON_STACK (end);
5118#else /* not GC_SAVE_REGISTERS_ON_STACK */
5119
5120#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
5121 setjmp will definitely work, test it
5122 and print a message with the result
5123 of the test. */
5124 if (!setjmp_tested_p)
5125 {
5126 setjmp_tested_p = 1;
5127 test_setjmp ();
5128 }
5129#endif /* GC_SETJMP_WORKS */
5130
5131 sys_setjmp (j.j);
5132 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
5133#endif /* not GC_SAVE_REGISTERS_ON_STACK */
5134#endif /* not HAVE___BUILTIN_UNWIND_INIT */
5135
5136 self->stack_top = end;
5137 (*func) (arg);
5138
5139 eassert (current_thread == self);
5140}
5141
5066static bool 5142static bool
5067c_symbol_p (struct Lisp_Symbol *sym) 5143c_symbol_p (struct Lisp_Symbol *sym)
5068{ 5144{
@@ -5768,24 +5844,14 @@ garbage_collect_1 (void *end)
5768 mark_object (*staticvec[i]); 5844 mark_object (*staticvec[i]);
5769 5845
5770 mark_pinned_symbols (); 5846 mark_pinned_symbols ();
5771 mark_specpdl ();
5772 mark_terminals (); 5847 mark_terminals ();
5773 mark_kboards (); 5848 mark_kboards ();
5849 mark_threads ();
5774 5850
5775#ifdef USE_GTK 5851#ifdef USE_GTK
5776 xg_mark_data (); 5852 xg_mark_data ();
5777#endif 5853#endif
5778 5854
5779 mark_stack (end);
5780
5781 {
5782 struct handler *handler;
5783 for (handler = handlerlist; handler; handler = handler->next)
5784 {
5785 mark_object (handler->tag_or_ch);
5786 mark_object (handler->val);
5787 }
5788 }
5789#ifdef HAVE_WINDOW_SYSTEM 5855#ifdef HAVE_WINDOW_SYSTEM
5790 mark_fringe_data (); 5856 mark_fringe_data ();
5791#endif 5857#endif
@@ -5817,6 +5883,8 @@ garbage_collect_1 (void *end)
5817 5883
5818 gc_sweep (); 5884 gc_sweep ();
5819 5885
5886 unmark_threads ();
5887
5820 /* Clear the mark bits that we set in certain root slots. */ 5888 /* Clear the mark bits that we set in certain root slots. */
5821 VECTOR_UNMARK (&buffer_defaults); 5889 VECTOR_UNMARK (&buffer_defaults);
5822 VECTOR_UNMARK (&buffer_local_symbols); 5890 VECTOR_UNMARK (&buffer_local_symbols);
diff --git a/src/buffer.c b/src/buffer.c
index 6815aa7f7ed..cea1ddb5ab3 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -48,8 +48,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
48#include "w32heap.h" /* for mmap_* */ 48#include "w32heap.h" /* for mmap_* */
49#endif 49#endif
50 50
51struct buffer *current_buffer; /* The current buffer. */
52
53/* First buffer in chain of all buffers (in reverse order of creation). 51/* First buffer in chain of all buffers (in reverse order of creation).
54 Threaded through ->header.next.buffer. */ 52 Threaded through ->header.next.buffer. */
55 53
@@ -1654,6 +1652,9 @@ cleaning up all windows currently displaying the buffer to be killed. */)
1654 if (!BUFFER_LIVE_P (b)) 1652 if (!BUFFER_LIVE_P (b))
1655 return Qnil; 1653 return Qnil;
1656 1654
1655 if (thread_check_current_buffer (b))
1656 return Qnil;
1657
1657 /* Run hooks with the buffer to be killed the current buffer. */ 1658 /* Run hooks with the buffer to be killed the current buffer. */
1658 { 1659 {
1659 ptrdiff_t count = SPECPDL_INDEX (); 1660 ptrdiff_t count = SPECPDL_INDEX ();
diff --git a/src/buffer.h b/src/buffer.h
index 6ac161c1c91..21ad5e3bc0f 100644
--- a/src/buffer.h
+++ b/src/buffer.h
@@ -1040,10 +1040,6 @@ extern struct buffer *all_buffers;
1040#define FOR_EACH_BUFFER(b) \ 1040#define FOR_EACH_BUFFER(b) \
1041 for ((b) = all_buffers; (b); (b) = (b)->next) 1041 for ((b) = all_buffers; (b); (b) = (b)->next)
1042 1042
1043/* This points to the current buffer. */
1044
1045extern struct buffer *current_buffer;
1046
1047/* This structure holds the default values of the buffer-local variables 1043/* This structure holds the default values of the buffer-local variables
1048 that have special slots in each buffer. 1044 that have special slots in each buffer.
1049 The default value occupies the same slot in this structure 1045 The default value occupies the same slot in this structure
diff --git a/src/bytecode.c b/src/bytecode.c
index 71ecdbf2cc0..c581ed6d982 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -280,10 +280,68 @@ enum byte_code_op
280 Bset_mark = 0163, /* this loser is no longer generated as of v18 */ 280 Bset_mark = 0163, /* this loser is no longer generated as of v18 */
281#endif 281#endif
282}; 282};
283
284/* Whether to maintain a `top' and `bottom' field in the stack frame. */
285#define BYTE_MAINTAIN_TOP BYTE_CODE_SAFE
283 286
284/* Fetch the next byte from the bytecode stream. */ 287/* Structure describing a value stack used during byte-code execution
288 in Fbyte_code. */
289
290struct byte_stack
291{
292 /* Program counter. This points into the byte_string below
293 and is relocated when that string is relocated. */
294 const unsigned char *pc;
295
296 /* Top and bottom of stack. The bottom points to an area of memory
297 allocated with alloca in Fbyte_code. */
298#if BYTE_MAINTAIN_TOP
299 Lisp_Object *top, *bottom;
300#endif
301
302 /* The string containing the byte-code, and its current address.
303 Storing this here protects it from GC because mark_byte_stack
304 marks it. */
305 Lisp_Object byte_string;
306 const unsigned char *byte_string_start;
307
308 /* Next entry in byte_stack_list. */
309 struct byte_stack *next;
310};
311
312/* A list of currently active byte-code execution value stacks.
313 Fbyte_code adds an entry to the head of this list before it starts
314 processing byte-code, and it removes the entry again when it is
315 done. Signaling an error truncates the list.
316
317 byte_stack_list is a macro defined in thread.h. */
318/* struct byte_stack *byte_stack_list; */
319
320
321/* Relocate program counters in the stacks on byte_stack_list. Called
322 when GC has completed. */
323
324void
325relocate_byte_stack (struct byte_stack *stack)
326{
327 for (; stack; stack = stack->next)
328 {
329 if (stack->byte_string_start != SDATA (stack->byte_string))
330 {
331 ptrdiff_t offset = stack->pc - stack->byte_string_start;
332 stack->byte_string_start = SDATA (stack->byte_string);
333 stack->pc = stack->byte_string_start + offset;
334 }
335 }
336}
285 337
286#define FETCH (*pc++) 338
339/* Fetch the next byte from the bytecode stream. */
340#ifdef BYTE_CODE_SAFE
341#define FETCH (eassert (stack.byte_string_start == SDATA (stack.byte_string)), *stack.pc++)
342#else
343#define FETCH *stack.pc++
344#endif
287 345
288/* Fetch two bytes from the bytecode stream and make a 16-bit number 346/* Fetch two bytes from the bytecode stream and make a 16-bit number
289 out of them. */ 347 out of them. */
@@ -308,6 +366,29 @@ enum byte_code_op
308 366
309#define TOP (*top) 367#define TOP (*top)
310 368
369#define CHECK_RANGE(ARG) \
370 (BYTE_CODE_SAFE && bytestr_length <= (ARG) ? emacs_abort () : (void) 0)
371
372/* A version of the QUIT macro which makes sure that the stack top is
373 set before signaling `quit'. */
374#define BYTE_CODE_QUIT \
375 do { \
376 if (quitcounter++) \
377 break; \
378 maybe_gc (); \
379 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \
380 { \
381 Lisp_Object flag = Vquit_flag; \
382 Vquit_flag = Qnil; \
383 if (EQ (Vthrow_on_input, flag)) \
384 Fthrow (Vthrow_on_input, Qt); \
385 quit (); \
386 } \
387 else if (pending_signals) \
388 process_pending_signals (); \
389 } while (0)
390
391
311DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0, 392DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
312 doc: /* Function used internally in byte-compiled code. 393 doc: /* Function used internally in byte-compiled code.
313The first argument, BYTESTR, is a string of byte code; 394The first argument, BYTESTR, is a string of byte code;
@@ -357,18 +438,19 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
357 438
358 ptrdiff_t bytestr_length = SBYTES (bytestr); 439 ptrdiff_t bytestr_length = SBYTES (bytestr);
359 Lisp_Object *vectorp = XVECTOR (vector)->contents; 440 Lisp_Object *vectorp = XVECTOR (vector)->contents;
441 struct byte_stack stack;
360 442
361 unsigned char quitcounter = 1; 443 stack.byte_string = bytestr;
444 stack.pc = stack.byte_string_start = SDATA (bytestr);
445 unsigned char quitcounter = 0;
362 EMACS_INT stack_items = XFASTINT (maxdepth) + 1; 446 EMACS_INT stack_items = XFASTINT (maxdepth) + 1;
363 USE_SAFE_ALLOCA; 447 USE_SAFE_ALLOCA;
364 Lisp_Object *stack_base; 448 Lisp_Object *stack_base;
365 SAFE_ALLOCA_LISP_EXTRA (stack_base, stack_items, bytestr_length); 449 SAFE_ALLOCA_LISP (stack_base, stack_items);
366 Lisp_Object *stack_lim = stack_base + stack_items; 450 Lisp_Object *stack_lim = stack_base + stack_items;
367 Lisp_Object *top = stack_base; 451 Lisp_Object *top = stack_base;
368 memcpy (stack_lim, SDATA (bytestr), bytestr_length); 452 stack.next = byte_stack_list;
369 void *void_stack_lim = stack_lim; 453 byte_stack_list = &stack;
370 unsigned char const *bytestr_data = void_stack_lim;
371 unsigned char const *pc = bytestr_data;
372 ptrdiff_t count = SPECPDL_INDEX (); 454 ptrdiff_t count = SPECPDL_INDEX ();
373 455
374 if (!NILP (args_template)) 456 if (!NILP (args_template))
@@ -508,10 +590,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
508 590
509 CASE (Bgotoifnil): 591 CASE (Bgotoifnil):
510 { 592 {
511 Lisp_Object v1 = POP; 593 Lisp_Object v1;
512 op = FETCH2; 594 op = FETCH2;
595 v1 = POP;
513 if (NILP (v1)) 596 if (NILP (v1))
514 goto op_branch; 597 {
598 BYTE_CODE_QUIT;
599 CHECK_RANGE (op);
600 stack.pc = stack.byte_string_start + op;
601 }
515 NEXT; 602 NEXT;
516 } 603 }
517 604
@@ -569,7 +656,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
569 if (SYMBOLP (sym) 656 if (SYMBOLP (sym)
570 && !EQ (val, Qunbound) 657 && !EQ (val, Qunbound)
571 && !XSYMBOL (sym)->redirect 658 && !XSYMBOL (sym)->redirect
572 && !SYMBOL_TRAPPED_WRITE_P (sym)) 659 && !SYMBOL_TRAPPED_WRITE_P (sym))
573 SET_SYMBOL_VAL (XSYMBOL (sym), val); 660 SET_SYMBOL_VAL (XSYMBOL (sym), val);
574 else 661 else
575 set_internal (sym, val, Qnil, SET_INTERNAL_SET); 662 set_internal (sym, val, Qnil, SET_INTERNAL_SET);
@@ -666,72 +753,86 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
666 NEXT; 753 NEXT;
667 754
668 CASE (Bgoto): 755 CASE (Bgoto):
669 op = FETCH2; 756 BYTE_CODE_QUIT;
670 op_branch: 757 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
671 op -= pc - bytestr_data; 758 CHECK_RANGE (op);
672 op_relative_branch: 759 stack.pc = stack.byte_string_start + op;
673 if (BYTE_CODE_SAFE
674 && ! (bytestr_data - pc <= op
675 && op < bytestr_data + bytestr_length - pc))
676 emacs_abort ();
677 quitcounter += op < 0;
678 if (!quitcounter)
679 {
680 quitcounter = 1;
681 maybe_gc ();
682 QUIT;
683 }
684 pc += op;
685 NEXT; 760 NEXT;
686 761
687 CASE (Bgotoifnonnil): 762 CASE (Bgotoifnonnil):
688 op = FETCH2; 763 op = FETCH2;
689 if (!NILP (POP)) 764 Lisp_Object v1 = POP;
690 goto op_branch; 765 if (!NILP (v1))
766 {
767 BYTE_CODE_QUIT;
768 CHECK_RANGE (op);
769 stack.pc = stack.byte_string_start + op;
770 }
691 NEXT; 771 NEXT;
692 772
693 CASE (Bgotoifnilelsepop): 773 CASE (Bgotoifnilelsepop):
694 op = FETCH2; 774 op = FETCH2;
695 if (NILP (TOP)) 775 if (NILP (TOP))
696 goto op_branch; 776 {
697 DISCARD (1); 777 BYTE_CODE_QUIT;
778 CHECK_RANGE (op);
779 stack.pc = stack.byte_string_start + op;
780 }
781 else DISCARD (1);
698 NEXT; 782 NEXT;
699 783
700 CASE (Bgotoifnonnilelsepop): 784 CASE (Bgotoifnonnilelsepop):
701 op = FETCH2; 785 op = FETCH2;
702 if (!NILP (TOP)) 786 if (!NILP (TOP))
703 goto op_branch; 787 {
704 DISCARD (1); 788 BYTE_CODE_QUIT;
789 CHECK_RANGE (op);
790 stack.pc = stack.byte_string_start + op;
791 }
792 else DISCARD (1);
705 NEXT; 793 NEXT;
706 794
707 CASE (BRgoto): 795 CASE (BRgoto):
708 op = FETCH - 128; 796 BYTE_CODE_QUIT;
709 goto op_relative_branch; 797 stack.pc += (int) *stack.pc - 127;
798 NEXT;
710 799
711 CASE (BRgotoifnil): 800 CASE (BRgotoifnil):
712 op = FETCH - 128;
713 if (NILP (POP)) 801 if (NILP (POP))
714 goto op_relative_branch; 802 {
803 BYTE_CODE_QUIT;
804 stack.pc += (int) *stack.pc - 128;
805 }
806 stack.pc++;
715 NEXT; 807 NEXT;
716 808
717 CASE (BRgotoifnonnil): 809 CASE (BRgotoifnonnil):
718 op = FETCH - 128;
719 if (!NILP (POP)) 810 if (!NILP (POP))
720 goto op_relative_branch; 811 {
812 BYTE_CODE_QUIT;
813 stack.pc += (int) *stack.pc - 128;
814 }
815 stack.pc++;
721 NEXT; 816 NEXT;
722 817
723 CASE (BRgotoifnilelsepop): 818 CASE (BRgotoifnilelsepop):
724 op = FETCH - 128; 819 op = *stack.pc++;
725 if (NILP (TOP)) 820 if (NILP (TOP))
726 goto op_relative_branch; 821 {
727 DISCARD (1); 822 BYTE_CODE_QUIT;
823 stack.pc += op - 128;
824 }
825 else DISCARD (1);
728 NEXT; 826 NEXT;
729 827
730 CASE (BRgotoifnonnilelsepop): 828 CASE (BRgotoifnonnilelsepop):
731 op = FETCH - 128; 829 op = *stack.pc++;
732 if (!NILP (TOP)) 830 if (!NILP (TOP))
733 goto op_relative_branch; 831 {
734 DISCARD (1); 832 BYTE_CODE_QUIT;
833 stack.pc += op - 128;
834 }
835 else DISCARD (1);
735 NEXT; 836 NEXT;
736 837
737 CASE (Breturn): 838 CASE (Breturn):
@@ -791,11 +892,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
791 if (sys_setjmp (c->jmp)) 892 if (sys_setjmp (c->jmp))
792 { 893 {
793 struct handler *c = handlerlist; 894 struct handler *c = handlerlist;
895 int dest;
794 top = c->bytecode_top; 896 top = c->bytecode_top;
795 op = c->bytecode_dest; 897 dest = c->bytecode_dest;
796 handlerlist = c->next; 898 handlerlist = c->next;
797 PUSH (c->val); 899 PUSH (c->val);
798 goto op_branch; 900 CHECK_RANGE (dest);
901 /* Might have been re-set by longjmp! */
902 stack.byte_string_start = SDATA (stack.byte_string);
903 stack.pc = stack.byte_string_start + dest;
799 } 904 }
800 905
801 NEXT; 906 NEXT;
@@ -1363,7 +1468,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
1363 call3 (Qerror, 1468 call3 (Qerror,
1364 build_string ("Invalid byte opcode: op=%s, ptr=%d"), 1469 build_string ("Invalid byte opcode: op=%s, ptr=%d"),
1365 make_number (op), 1470 make_number (op),
1366 make_number (pc - 1 - bytestr_data)); 1471 make_number (stack.pc - 1 - stack.byte_string_start));
1367 1472
1368 /* Handy byte-codes for lexical binding. */ 1473 /* Handy byte-codes for lexical binding. */
1369 CASE (Bstack_ref1): 1474 CASE (Bstack_ref1):
@@ -1423,6 +1528,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
1423 1528
1424 exit: 1529 exit:
1425 1530
1531 byte_stack_list = byte_stack_list->next;
1532
1426 /* Binds and unbinds are supposed to be compiled balanced. */ 1533 /* Binds and unbinds are supposed to be compiled balanced. */
1427 if (SPECPDL_INDEX () != count) 1534 if (SPECPDL_INDEX () != count)
1428 { 1535 {
diff --git a/src/data.c b/src/data.c
index 64cd8b23b46..09d94f57a8e 100644
--- a/src/data.c
+++ b/src/data.c
@@ -258,6 +258,12 @@ for example, (type-of 1) returns `integer'. */)
258 return Qfont_entity; 258 return Qfont_entity;
259 if (FONT_OBJECT_P (object)) 259 if (FONT_OBJECT_P (object))
260 return Qfont_object; 260 return Qfont_object;
261 if (THREADP (object))
262 return Qthread;
263 if (MUTEXP (object))
264 return Qmutex;
265 if (CONDVARP (object))
266 return Qcondition_variable;
261 return Qvector; 267 return Qvector;
262 268
263 case Lisp_Float: 269 case Lisp_Float:
@@ -528,6 +534,33 @@ DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
528 return Qnil; 534 return Qnil;
529} 535}
530 536
537DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0,
538 doc: /* Return t if OBJECT is a thread. */)
539 (Lisp_Object object)
540{
541 if (THREADP (object))
542 return Qt;
543 return Qnil;
544}
545
546DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0,
547 doc: /* Return t if OBJECT is a mutex. */)
548 (Lisp_Object object)
549{
550 if (MUTEXP (object))
551 return Qt;
552 return Qnil;
553}
554
555DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p,
556 1, 1, 0,
557 doc: /* Return t if OBJECT is a condition variable. */)
558 (Lisp_Object object)
559{
560 if (CONDVARP (object))
561 return Qt;
562 return Qnil;
563}
531 564
532/* Extract and set components of lists. */ 565/* Extract and set components of lists. */
533 566
@@ -3756,6 +3789,9 @@ syms_of_data (void)
3756 DEFSYM (Qchar_table, "char-table"); 3789 DEFSYM (Qchar_table, "char-table");
3757 DEFSYM (Qbool_vector, "bool-vector"); 3790 DEFSYM (Qbool_vector, "bool-vector");
3758 DEFSYM (Qhash_table, "hash-table"); 3791 DEFSYM (Qhash_table, "hash-table");
3792 DEFSYM (Qthread, "thread");
3793 DEFSYM (Qmutex, "mutex");
3794 DEFSYM (Qcondition_variable, "condition-variable");
3759 3795
3760 DEFSYM (Qdefun, "defun"); 3796 DEFSYM (Qdefun, "defun");
3761 3797
@@ -3796,6 +3832,9 @@ syms_of_data (void)
3796 defsubr (&Ssubrp); 3832 defsubr (&Ssubrp);
3797 defsubr (&Sbyte_code_function_p); 3833 defsubr (&Sbyte_code_function_p);
3798 defsubr (&Schar_or_string_p); 3834 defsubr (&Schar_or_string_p);
3835 defsubr (&Sthreadp);
3836 defsubr (&Smutexp);
3837 defsubr (&Scondition_variable_p);
3799 defsubr (&Scar); 3838 defsubr (&Scar);
3800 defsubr (&Scdr); 3839 defsubr (&Scdr);
3801 defsubr (&Scar_safe); 3840 defsubr (&Scar_safe);
diff --git a/src/emacs.c b/src/emacs.c
index 75b2d6ed607..424ee05a42c 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -155,10 +155,6 @@ bool running_asynch_code;
155bool display_arg; 155bool display_arg;
156#endif 156#endif
157 157
158/* An address near the bottom of the stack.
159 Tells GC how to save a copy of the stack. */
160char *stack_bottom;
161
162#if defined GNU_LINUX && !defined CANNOT_DUMP 158#if defined GNU_LINUX && !defined CANNOT_DUMP
163/* The gap between BSS end and heap start as far as we can tell. */ 159/* The gap between BSS end and heap start as far as we can tell. */
164static uprintmax_t heap_bss_diff; 160static uprintmax_t heap_bss_diff;
@@ -670,7 +666,6 @@ close_output_streams (void)
670int 666int
671main (int argc, char **argv) 667main (int argc, char **argv)
672{ 668{
673 Lisp_Object dummy;
674 char stack_bottom_variable; 669 char stack_bottom_variable;
675 bool do_initial_setlocale; 670 bool do_initial_setlocale;
676 bool dumping; 671 bool dumping;
@@ -686,7 +681,8 @@ main (int argc, char **argv)
686 /* If we use --chdir, this records the original directory. */ 681 /* If we use --chdir, this records the original directory. */
687 char *original_pwd = 0; 682 char *original_pwd = 0;
688 683
689 stack_base = &dummy; 684 /* Record (approximately) where the stack begins. */
685 stack_bottom = &stack_bottom_variable;
690 686
691 dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0 687 dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0
692 || strcmp (argv[argc - 1], "bootstrap") == 0); 688 || strcmp (argv[argc - 1], "bootstrap") == 0);
@@ -881,9 +877,6 @@ main (int argc, char **argv)
881 } 877 }
882#endif /* HAVE_SETRLIMIT and RLIMIT_STACK and not CYGWIN */ 878#endif /* HAVE_SETRLIMIT and RLIMIT_STACK and not CYGWIN */
883 879
884 /* Record (approximately) where the stack begins. */
885 stack_bottom = &stack_bottom_variable;
886
887 clearerr (stdin); 880 clearerr (stdin);
888 881
889 emacs_backtrace (-1); 882 emacs_backtrace (-1);
@@ -1197,6 +1190,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
1197 if (!initialized) 1190 if (!initialized)
1198 { 1191 {
1199 init_alloc_once (); 1192 init_alloc_once ();
1193 init_threads_once ();
1200 init_obarray (); 1194 init_obarray ();
1201 init_eval_once (); 1195 init_eval_once ();
1202 init_charset_once (); 1196 init_charset_once ();
@@ -1243,6 +1237,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
1243 } 1237 }
1244 1238
1245 init_alloc (); 1239 init_alloc ();
1240 init_threads ();
1246 1241
1247 if (do_initial_setlocale) 1242 if (do_initial_setlocale)
1248 { 1243 {
@@ -1585,6 +1580,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
1585#endif /* HAVE_W32NOTIFY */ 1580#endif /* HAVE_W32NOTIFY */
1586#endif /* WINDOWSNT */ 1581#endif /* WINDOWSNT */
1587 1582
1583 syms_of_threads ();
1588 syms_of_profiler (); 1584 syms_of_profiler ();
1589 1585
1590 keys_of_casefiddle (); 1586 keys_of_casefiddle ();
diff --git a/src/eval.c b/src/eval.c
index 8ad06dded80..f1e0ae7d586 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -32,7 +32,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
32 32
33/* Chain of condition and catch handlers currently in effect. */ 33/* Chain of condition and catch handlers currently in effect. */
34 34
35struct handler *handlerlist; 35/* struct handler *handlerlist; */
36 36
37/* Non-nil means record all fset's and provide's, to be undone 37/* Non-nil means record all fset's and provide's, to be undone
38 if the file being autoloaded is not fully loaded. 38 if the file being autoloaded is not fully loaded.
@@ -46,23 +46,25 @@ Lisp_Object Vautoload_queue;
46 is shutting down. */ 46 is shutting down. */
47Lisp_Object Vrun_hooks; 47Lisp_Object Vrun_hooks;
48 48
49/* The commented-out variables below are macros defined in thread.h. */
50
49/* Current number of specbindings allocated in specpdl, not counting 51/* Current number of specbindings allocated in specpdl, not counting
50 the dummy entry specpdl[-1]. */ 52 the dummy entry specpdl[-1]. */
51 53
52ptrdiff_t specpdl_size; 54/* ptrdiff_t specpdl_size; */
53 55
54/* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists 56/* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
55 only so that its address can be taken. */ 57 only so that its address can be taken. */
56 58
57union specbinding *specpdl; 59/* union specbinding *specpdl; */
58 60
59/* Pointer to first unused element in specpdl. */ 61/* Pointer to first unused element in specpdl. */
60 62
61union specbinding *specpdl_ptr; 63/* union specbinding *specpdl_ptr; */
62 64
63/* Depth in Lisp evaluations and function calls. */ 65/* Depth in Lisp evaluations and function calls. */
64 66
65static EMACS_INT lisp_eval_depth; 67/* static EMACS_INT lisp_eval_depth; */
66 68
67/* The value of num_nonmacro_input_events as of the last time we 69/* The value of num_nonmacro_input_events as of the last time we
68 started to enter the debugger. If we decide to enter the debugger 70 started to enter the debugger. If we decide to enter the debugger
@@ -100,6 +102,13 @@ specpdl_symbol (union specbinding *pdl)
100 return pdl->let.symbol; 102 return pdl->let.symbol;
101} 103}
102 104
105static enum specbind_tag
106specpdl_kind (union specbinding *pdl)
107{
108 eassert (pdl->kind >= SPECPDL_LET);
109 return pdl->let.kind;
110}
111
103static Lisp_Object 112static Lisp_Object
104specpdl_old_value (union specbinding *pdl) 113specpdl_old_value (union specbinding *pdl)
105{ 114{
@@ -122,6 +131,13 @@ specpdl_where (union specbinding *pdl)
122} 131}
123 132
124static Lisp_Object 133static Lisp_Object
134specpdl_saved_value (union specbinding *pdl)
135{
136 eassert (pdl->kind >= SPECPDL_LET);
137 return pdl->let.saved_value;
138}
139
140static Lisp_Object
125specpdl_arg (union specbinding *pdl) 141specpdl_arg (union specbinding *pdl)
126{ 142{
127 eassert (pdl->kind == SPECPDL_UNWIND); 143 eassert (pdl->kind == SPECPDL_UNWIND);
@@ -218,20 +234,22 @@ init_eval_once (void)
218 Vrun_hooks = Qnil; 234 Vrun_hooks = Qnil;
219} 235}
220 236
221static struct handler handlerlist_sentinel; 237/* static struct handler handlerlist_sentinel; */
222 238
223void 239void
224init_eval (void) 240init_eval (void)
225{ 241{
242 byte_stack_list = 0;
226 specpdl_ptr = specpdl; 243 specpdl_ptr = specpdl;
227 { /* Put a dummy catcher at top-level so that handlerlist is never NULL. 244 { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
228 This is important since handlerlist->nextfree holds the freelist 245 This is important since handlerlist->nextfree holds the freelist
229 which would otherwise leak every time we unwind back to top-level. */ 246 which would otherwise leak every time we unwind back to top-level. */
230 handlerlist = handlerlist_sentinel.nextfree = &handlerlist_sentinel; 247 handlerlist_sentinel = xzalloc (sizeof (struct handler));
248 handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
231 struct handler *c = push_handler (Qunbound, CATCHER); 249 struct handler *c = push_handler (Qunbound, CATCHER);
232 eassert (c == &handlerlist_sentinel); 250 eassert (c == handlerlist_sentinel);
233 handlerlist_sentinel.nextfree = NULL; 251 handlerlist_sentinel->nextfree = NULL;
234 handlerlist_sentinel.next = NULL; 252 handlerlist_sentinel->next = NULL;
235 } 253 }
236 Vquit_flag = Qnil; 254 Vquit_flag = Qnil;
237 debug_on_next_call = 0; 255 debug_on_next_call = 0;
@@ -1138,7 +1156,8 @@ unwind_to_catch (struct handler *catch, Lisp_Object value)
1138 1156
1139 eassert (handlerlist == catch); 1157 eassert (handlerlist == catch);
1140 1158
1141 lisp_eval_depth = catch->lisp_eval_depth; 1159 byte_stack_list = catch->byte_stack;
1160 lisp_eval_depth = catch->f_lisp_eval_depth;
1142 1161
1143 sys_longjmp (catch->jmp, 1); 1162 sys_longjmp (catch->jmp, 1);
1144} 1163}
@@ -1428,10 +1447,11 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
1428 c->tag_or_ch = tag_ch_val; 1447 c->tag_or_ch = tag_ch_val;
1429 c->val = Qnil; 1448 c->val = Qnil;
1430 c->next = handlerlist; 1449 c->next = handlerlist;
1431 c->lisp_eval_depth = lisp_eval_depth; 1450 c->f_lisp_eval_depth = lisp_eval_depth;
1432 c->pdlcount = SPECPDL_INDEX (); 1451 c->pdlcount = SPECPDL_INDEX ();
1433 c->poll_suppress_count = poll_suppress_count; 1452 c->poll_suppress_count = poll_suppress_count;
1434 c->interrupt_input_blocked = interrupt_input_blocked; 1453 c->interrupt_input_blocked = interrupt_input_blocked;
1454 c->byte_stack = byte_stack_list;
1435 handlerlist = c; 1455 handlerlist = c;
1436 return c; 1456 return c;
1437} 1457}
@@ -1581,7 +1601,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
1581 } 1601 }
1582 else 1602 else
1583 { 1603 {
1584 if (handlerlist != &handlerlist_sentinel) 1604 if (handlerlist != handlerlist_sentinel)
1585 /* FIXME: This will come right back here if there's no `top-level' 1605 /* FIXME: This will come right back here if there's no `top-level'
1586 catcher. A better solution would be to abort here, and instead 1606 catcher. A better solution would be to abort here, and instead
1587 add a catch-all condition handler so we never come here. */ 1607 add a catch-all condition handler so we never come here. */
@@ -3175,6 +3195,36 @@ let_shadows_global_binding_p (Lisp_Object symbol)
3175 return 0; 3195 return 0;
3176} 3196}
3177 3197
3198static void
3199do_specbind (struct Lisp_Symbol *sym, union specbinding *bind,
3200 Lisp_Object value)
3201{
3202 switch (sym->redirect)
3203 {
3204 case SYMBOL_PLAINVAL:
3205 if (!sym->trapped_write)
3206 SET_SYMBOL_VAL (sym, value);
3207 else
3208 set_internal (specpdl_symbol (bind), value, Qnil, SET_INTERNAL_BIND);
3209 break;
3210
3211 case SYMBOL_FORWARDED:
3212 if (BUFFER_OBJFWDP (SYMBOL_FWD (sym))
3213 && specpdl_kind (bind) == SPECPDL_LET_DEFAULT)
3214 {
3215 Fset_default (specpdl_symbol (bind), value);
3216 return;
3217 }
3218 /* FALLTHROUGH */
3219 case SYMBOL_LOCALIZED:
3220 set_internal (specpdl_symbol (bind), value, Qnil, SET_INTERNAL_BIND);
3221 break;
3222
3223 default:
3224 emacs_abort ();
3225 }
3226}
3227
3178/* `specpdl_ptr' describes which variable is 3228/* `specpdl_ptr' describes which variable is
3179 let-bound, so it can be properly undone when we unbind_to. 3229 let-bound, so it can be properly undone when we unbind_to.
3180 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT. 3230 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
@@ -3206,11 +3256,9 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3206 specpdl_ptr->let.kind = SPECPDL_LET; 3256 specpdl_ptr->let.kind = SPECPDL_LET;
3207 specpdl_ptr->let.symbol = symbol; 3257 specpdl_ptr->let.symbol = symbol;
3208 specpdl_ptr->let.old_value = SYMBOL_VAL (sym); 3258 specpdl_ptr->let.old_value = SYMBOL_VAL (sym);
3259 specpdl_ptr->let.saved_value = Qnil;
3209 grow_specpdl (); 3260 grow_specpdl ();
3210 if (!sym->trapped_write) 3261 do_specbind (sym, specpdl_ptr - 1, value);
3211 SET_SYMBOL_VAL (sym, value);
3212 else
3213 set_internal (symbol, value, Qnil, SET_INTERNAL_BIND);
3214 break; 3262 break;
3215 case SYMBOL_LOCALIZED: 3263 case SYMBOL_LOCALIZED:
3216 if (SYMBOL_BLV (sym)->frame_local) 3264 if (SYMBOL_BLV (sym)->frame_local)
@@ -3222,6 +3270,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3222 specpdl_ptr->let.symbol = symbol; 3270 specpdl_ptr->let.symbol = symbol;
3223 specpdl_ptr->let.old_value = ovalue; 3271 specpdl_ptr->let.old_value = ovalue;
3224 specpdl_ptr->let.where = Fcurrent_buffer (); 3272 specpdl_ptr->let.where = Fcurrent_buffer ();
3273 specpdl_ptr->let.saved_value = Qnil;
3225 3274
3226 eassert (sym->redirect != SYMBOL_LOCALIZED 3275 eassert (sym->redirect != SYMBOL_LOCALIZED
3227 || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ()))); 3276 || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
@@ -3242,7 +3291,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3242 { 3291 {
3243 specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT; 3292 specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
3244 grow_specpdl (); 3293 grow_specpdl ();
3245 Fset_default (symbol, value); 3294 do_specbind (sym, specpdl_ptr - 1, value);
3246 return; 3295 return;
3247 } 3296 }
3248 } 3297 }
@@ -3250,7 +3299,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3250 specpdl_ptr->let.kind = SPECPDL_LET; 3299 specpdl_ptr->let.kind = SPECPDL_LET;
3251 3300
3252 grow_specpdl (); 3301 grow_specpdl ();
3253 set_internal (symbol, value, Qnil, SET_INTERNAL_BIND); 3302 do_specbind (sym, specpdl_ptr - 1, value);
3254 break; 3303 break;
3255 } 3304 }
3256 default: emacs_abort (); 3305 default: emacs_abort ();
@@ -3294,6 +3343,91 @@ record_unwind_protect_void (void (*function) (void))
3294 grow_specpdl (); 3343 grow_specpdl ();
3295} 3344}
3296 3345
3346void
3347rebind_for_thread_switch (void)
3348{
3349 union specbinding *bind;
3350
3351 for (bind = specpdl; bind != specpdl_ptr; ++bind)
3352 {
3353 if (bind->kind >= SPECPDL_LET)
3354 {
3355 Lisp_Object value = specpdl_saved_value (bind);
3356 Lisp_Object sym = specpdl_symbol (bind);
3357 bool was_trapped =
3358 SYMBOLP (sym)
3359 && XSYMBOL (sym)->trapped_write == SYMBOL_TRAPPED_WRITE;
3360 /* FIXME: This is not clean, and if do_specbind signals an
3361 error, the symbol will be left untrapped. */
3362 if (was_trapped)
3363 XSYMBOL (sym)->trapped_write = SYMBOL_UNTRAPPED_WRITE;
3364 bind->let.saved_value = Qnil;
3365 do_specbind (XSYMBOL (sym), bind, value);
3366 if (was_trapped)
3367 XSYMBOL (sym)->trapped_write = SYMBOL_TRAPPED_WRITE;
3368 }
3369 }
3370}
3371
3372static void
3373do_one_unbind (union specbinding *this_binding, bool unwinding)
3374{
3375 eassert (unwinding || this_binding->kind >= SPECPDL_LET);
3376 switch (this_binding->kind)
3377 {
3378 case SPECPDL_UNWIND:
3379 this_binding->unwind.func (this_binding->unwind.arg);
3380 break;
3381 case SPECPDL_UNWIND_PTR:
3382 this_binding->unwind_ptr.func (this_binding->unwind_ptr.arg);
3383 break;
3384 case SPECPDL_UNWIND_INT:
3385 this_binding->unwind_int.func (this_binding->unwind_int.arg);
3386 break;
3387 case SPECPDL_UNWIND_VOID:
3388 this_binding->unwind_void.func ();
3389 break;
3390 case SPECPDL_BACKTRACE:
3391 break;
3392 case SPECPDL_LET:
3393 { /* If variable has a trivial value (no forwarding), and isn't
3394 trapped, we can just set it. */
3395 Lisp_Object sym = specpdl_symbol (this_binding);
3396 if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL)
3397 {
3398 if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE)
3399 SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value (this_binding));
3400 else
3401 set_internal (sym, specpdl_old_value (this_binding),
3402 Qnil, SET_INTERNAL_UNBIND);
3403 break;
3404 }
3405 else
3406 { /* FALLTHROUGH!!
3407 NOTE: we only ever come here if make_local_foo was used for
3408 the first time on this var within this let. */
3409 }
3410 }
3411 case SPECPDL_LET_DEFAULT:
3412 Fset_default (specpdl_symbol (this_binding),
3413 specpdl_old_value (this_binding));
3414 break;
3415 case SPECPDL_LET_LOCAL:
3416 {
3417 Lisp_Object symbol = specpdl_symbol (this_binding);
3418 Lisp_Object where = specpdl_where (this_binding);
3419 Lisp_Object old_value = specpdl_old_value (this_binding);
3420 eassert (BUFFERP (where));
3421
3422 /* If this was a local binding, reset the value in the appropriate
3423 buffer, but only if that buffer's binding still exists. */
3424 if (!NILP (Flocal_variable_p (symbol, where)))
3425 set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND);
3426 }
3427 break;
3428 }
3429}
3430
3297static void 3431static void
3298do_nothing (void) 3432do_nothing (void)
3299{} 3433{}
@@ -3353,66 +3487,16 @@ unbind_to (ptrdiff_t count, Lisp_Object value)
3353 3487
3354 while (specpdl_ptr != specpdl + count) 3488 while (specpdl_ptr != specpdl + count)
3355 { 3489 {
3356 /* Decrement specpdl_ptr before we do the work to unbind it, so 3490 /* Copy the binding, and decrement specpdl_ptr, before we do
3357 that an error in unbinding won't try to unbind the same entry 3491 the work to unbind it. We decrement first
3358 again. Take care to copy any parts of the binding needed 3492 so that an error in unbinding won't try to unbind
3359 before invoking any code that can make more bindings. */ 3493 the same entry again, and we copy the binding first
3494 in case more bindings are made during some of the code we run. */
3360 3495
3361 specpdl_ptr--; 3496 union specbinding this_binding;
3362 3497 this_binding = *--specpdl_ptr;
3363 switch (specpdl_ptr->kind)
3364 {
3365 case SPECPDL_UNWIND:
3366 specpdl_ptr->unwind.func (specpdl_ptr->unwind.arg);
3367 break;
3368 case SPECPDL_UNWIND_PTR:
3369 specpdl_ptr->unwind_ptr.func (specpdl_ptr->unwind_ptr.arg);
3370 break;
3371 case SPECPDL_UNWIND_INT:
3372 specpdl_ptr->unwind_int.func (specpdl_ptr->unwind_int.arg);
3373 break;
3374 case SPECPDL_UNWIND_VOID:
3375 specpdl_ptr->unwind_void.func ();
3376 break;
3377 case SPECPDL_BACKTRACE:
3378 break;
3379 case SPECPDL_LET:
3380 { /* If variable has a trivial value (no forwarding), and
3381 isn't trapped, we can just set it. */
3382 Lisp_Object sym = specpdl_symbol (specpdl_ptr);
3383 if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL)
3384 {
3385 if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE)
3386 SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value (specpdl_ptr));
3387 else
3388 set_internal (sym, specpdl_old_value (specpdl_ptr),
3389 Qnil, SET_INTERNAL_UNBIND);
3390 break;
3391 }
3392 else
3393 { /* FALLTHROUGH!!
3394 NOTE: we only ever come here if make_local_foo was used for
3395 the first time on this var within this let. */
3396 }
3397 }
3398 case SPECPDL_LET_DEFAULT:
3399 Fset_default (specpdl_symbol (specpdl_ptr),
3400 specpdl_old_value (specpdl_ptr));
3401 break;
3402 case SPECPDL_LET_LOCAL:
3403 {
3404 Lisp_Object symbol = specpdl_symbol (specpdl_ptr);
3405 Lisp_Object where = specpdl_where (specpdl_ptr);
3406 Lisp_Object old_value = specpdl_old_value (specpdl_ptr);
3407 eassert (BUFFERP (where));
3408 3498
3409 /* If this was a local binding, reset the value in the appropriate 3499 do_one_unbind (&this_binding, true);
3410 buffer, but only if that buffer's binding still exists. */
3411 if (!NILP (Flocal_variable_p (symbol, where)))
3412 set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND);
3413 }
3414 break;
3415 }
3416 } 3500 }
3417 3501
3418 if (NILP (Vquit_flag) && !NILP (quitf)) 3502 if (NILP (Vquit_flag) && !NILP (quitf))
@@ -3421,6 +3505,31 @@ unbind_to (ptrdiff_t count, Lisp_Object value)
3421 return value; 3505 return value;
3422} 3506}
3423 3507
3508void
3509unbind_for_thread_switch (struct thread_state *thr)
3510{
3511 union specbinding *bind;
3512
3513 for (bind = thr->m_specpdl_ptr; bind > thr->m_specpdl;)
3514 {
3515 if ((--bind)->kind >= SPECPDL_LET)
3516 {
3517 Lisp_Object sym = specpdl_symbol (bind);
3518 bool was_trapped =
3519 SYMBOLP (sym)
3520 && XSYMBOL (sym)->trapped_write == SYMBOL_TRAPPED_WRITE;
3521 bind->let.saved_value = find_symbol_value (sym);
3522 /* FIXME: This is not clean, and if do_one_unbind signals an
3523 error, the symbol will be left untrapped. */
3524 if (was_trapped)
3525 XSYMBOL (sym)->trapped_write = SYMBOL_UNTRAPPED_WRITE;
3526 do_one_unbind (bind, false);
3527 if (was_trapped)
3528 XSYMBOL (sym)->trapped_write = SYMBOL_TRAPPED_WRITE;
3529 }
3530 }
3531}
3532
3424DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0, 3533DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
3425 doc: /* Return non-nil if SYMBOL's global binding has been declared special. 3534 doc: /* Return non-nil if SYMBOL's global binding has been declared special.
3426A special variable is one that will be bound dynamically, even in a 3535A special variable is one that will be bound dynamically, even in a
@@ -3743,10 +3852,10 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'.
3743 3852
3744 3853
3745void 3854void
3746mark_specpdl (void) 3855mark_specpdl (union specbinding *first, union specbinding *ptr)
3747{ 3856{
3748 union specbinding *pdl; 3857 union specbinding *pdl;
3749 for (pdl = specpdl; pdl != specpdl_ptr; pdl++) 3858 for (pdl = first; pdl != ptr; pdl++)
3750 { 3859 {
3751 switch (pdl->kind) 3860 switch (pdl->kind)
3752 { 3861 {
@@ -3772,6 +3881,7 @@ mark_specpdl (void)
3772 case SPECPDL_LET: 3881 case SPECPDL_LET:
3773 mark_object (specpdl_symbol (pdl)); 3882 mark_object (specpdl_symbol (pdl));
3774 mark_object (specpdl_old_value (pdl)); 3883 mark_object (specpdl_old_value (pdl));
3884 mark_object (specpdl_saved_value (pdl));
3775 break; 3885 break;
3776 3886
3777 case SPECPDL_UNWIND_PTR: 3887 case SPECPDL_UNWIND_PTR:
diff --git a/src/lisp.h b/src/lisp.h
index 11e49b6ee7e..252707c3495 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -34,6 +34,8 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
34#include <intprops.h> 34#include <intprops.h>
35#include <verify.h> 35#include <verify.h>
36 36
37#include "systhread.h"
38
37INLINE_HEADER_BEGIN 39INLINE_HEADER_BEGIN
38 40
39/* Define a TYPE constant ID as an externally visible name. Use like this: 41/* Define a TYPE constant ID as an externally visible name. Use like this:
@@ -588,6 +590,9 @@ INLINE bool (SYMBOLP) (Lisp_Object);
588INLINE bool (VECTORLIKEP) (Lisp_Object); 590INLINE bool (VECTORLIKEP) (Lisp_Object);
589INLINE bool WINDOWP (Lisp_Object); 591INLINE bool WINDOWP (Lisp_Object);
590INLINE bool TERMINALP (Lisp_Object); 592INLINE bool TERMINALP (Lisp_Object);
593INLINE bool THREADP (Lisp_Object);
594INLINE bool MUTEXP (Lisp_Object);
595INLINE bool CONDVARP (Lisp_Object);
591INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object); 596INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object);
592INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object); 597INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object);
593INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object); 598INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object);
@@ -756,6 +761,39 @@ struct Lisp_Symbol
756 761
757#include "globals.h" 762#include "globals.h"
758 763
764/* Header of vector-like objects. This documents the layout constraints on
765 vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
766 compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
767 and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
768 because when two such pointers potentially alias, a compiler won't
769 incorrectly reorder loads and stores to their size fields. See
770 Bug#8546. */
771struct vectorlike_header
772 {
773 /* The only field contains various pieces of information:
774 - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
775 - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
776 vector (0) or a pseudovector (1).
777 - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
778 of slots) of the vector.
779 - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
780 - a) pseudovector subtype held in PVEC_TYPE_MASK field;
781 - b) number of Lisp_Objects slots at the beginning of the object
782 held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
783 traced by the GC;
784 - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
785 measured in word_size units. Rest fields may also include
786 Lisp_Objects, but these objects usually needs some special treatment
787 during GC.
788 There are some exceptions. For PVEC_FREE, b) is always zero. For
789 PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
790 Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
791 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
792 ptrdiff_t size;
793 };
794
795#include "thread.h"
796
759/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa. 797/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa.
760 At the machine level, these operations are no-ops. */ 798 At the machine level, these operations are no-ops. */
761 799
@@ -802,6 +840,9 @@ enum pvec_type
802 PVEC_OTHER, 840 PVEC_OTHER,
803 PVEC_XWIDGET, 841 PVEC_XWIDGET,
804 PVEC_XWIDGET_VIEW, 842 PVEC_XWIDGET_VIEW,
843 PVEC_THREAD,
844 PVEC_MUTEX,
845 PVEC_CONDVAR,
805 846
806 /* These should be last, check internal_equal to see why. */ 847 /* These should be last, check internal_equal to see why. */
807 PVEC_COMPILED, 848 PVEC_COMPILED,
@@ -1105,6 +1146,27 @@ XBOOL_VECTOR (Lisp_Object a)
1105 return XUNTAG (a, Lisp_Vectorlike); 1146 return XUNTAG (a, Lisp_Vectorlike);
1106} 1147}
1107 1148
1149INLINE struct thread_state *
1150XTHREAD (Lisp_Object a)
1151{
1152 eassert (THREADP (a));
1153 return XUNTAG (a, Lisp_Vectorlike);
1154}
1155
1156INLINE struct Lisp_Mutex *
1157XMUTEX (Lisp_Object a)
1158{
1159 eassert (MUTEXP (a));
1160 return XUNTAG (a, Lisp_Vectorlike);
1161}
1162
1163INLINE struct Lisp_CondVar *
1164XCONDVAR (Lisp_Object a)
1165{
1166 eassert (CONDVARP (a));
1167 return XUNTAG (a, Lisp_Vectorlike);
1168}
1169
1108/* Construct a Lisp_Object from a value or address. */ 1170/* Construct a Lisp_Object from a value or address. */
1109 1171
1110INLINE Lisp_Object 1172INLINE Lisp_Object
@@ -1171,6 +1233,9 @@ builtin_lisp_symbol (int index)
1171#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) 1233#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
1172#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) 1234#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
1173#define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE)) 1235#define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE))
1236#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD))
1237#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX))
1238#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR))
1174 1239
1175/* Efficiently convert a pointer to a Lisp object and back. The 1240/* Efficiently convert a pointer to a Lisp object and back. The
1176 pointer is represented as a Lisp integer, so the garbage collector 1241 pointer is represented as a Lisp integer, so the garbage collector
@@ -1402,37 +1467,6 @@ STRING_SET_CHARS (Lisp_Object string, ptrdiff_t newsize)
1402 XSTRING (string)->size = newsize; 1467 XSTRING (string)->size = newsize;
1403} 1468}
1404 1469
1405/* Header of vector-like objects. This documents the layout constraints on
1406 vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
1407 compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
1408 and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
1409 because when two such pointers potentially alias, a compiler won't
1410 incorrectly reorder loads and stores to their size fields. See
1411 Bug#8546. */
1412struct vectorlike_header
1413 {
1414 /* The only field contains various pieces of information:
1415 - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
1416 - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
1417 vector (0) or a pseudovector (1).
1418 - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
1419 of slots) of the vector.
1420 - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
1421 - a) pseudovector subtype held in PVEC_TYPE_MASK field;
1422 - b) number of Lisp_Objects slots at the beginning of the object
1423 held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
1424 traced by the GC;
1425 - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
1426 measured in word_size units. Rest fields may also include
1427 Lisp_Objects, but these objects usually needs some special treatment
1428 during GC.
1429 There are some exceptions. For PVEC_FREE, b) is always zero. For
1430 PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
1431 Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
1432 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
1433 ptrdiff_t size;
1434 };
1435
1436/* A regular vector is just a header plus an array of Lisp_Objects. */ 1470/* A regular vector is just a header plus an array of Lisp_Objects. */
1437 1471
1438struct Lisp_Vector 1472struct Lisp_Vector
@@ -2782,6 +2816,24 @@ FRAMEP (Lisp_Object a)
2782 return PSEUDOVECTORP (a, PVEC_FRAME); 2816 return PSEUDOVECTORP (a, PVEC_FRAME);
2783} 2817}
2784 2818
2819INLINE bool
2820THREADP (Lisp_Object a)
2821{
2822 return PSEUDOVECTORP (a, PVEC_THREAD);
2823}
2824
2825INLINE bool
2826MUTEXP (Lisp_Object a)
2827{
2828 return PSEUDOVECTORP (a, PVEC_MUTEX);
2829}
2830
2831INLINE bool
2832CONDVARP (Lisp_Object a)
2833{
2834 return PSEUDOVECTORP (a, PVEC_CONDVAR);
2835}
2836
2785/* Test for image (image . spec) */ 2837/* Test for image (image . spec) */
2786INLINE bool 2838INLINE bool
2787IMAGEP (Lisp_Object x) 2839IMAGEP (Lisp_Object x)
@@ -2930,6 +2982,25 @@ CHECK_NUMBER_OR_FLOAT (Lisp_Object x)
2930 CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \ 2982 CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \
2931 } while (false) 2983 } while (false)
2932 2984
2985
2986INLINE void
2987CHECK_THREAD (Lisp_Object x)
2988{
2989 CHECK_TYPE (THREADP (x), Qthreadp, x);
2990}
2991
2992INLINE void
2993CHECK_MUTEX (Lisp_Object x)
2994{
2995 CHECK_TYPE (MUTEXP (x), Qmutexp, x);
2996}
2997
2998INLINE void
2999CHECK_CONDVAR (Lisp_Object x)
3000{
3001 CHECK_TYPE (CONDVARP (x), Qcondition_variable_p, x);
3002}
3003
2933/* Since we can't assign directly to the CAR or CDR fields of a cons 3004/* Since we can't assign directly to the CAR or CDR fields of a cons
2934 cell, use these when checking that those fields contain numbers. */ 3005 cell, use these when checking that those fields contain numbers. */
2935INLINE void 3006INLINE void
@@ -3141,6 +3212,9 @@ union specbinding
3141 ENUM_BF (specbind_tag) kind : CHAR_BIT; 3212 ENUM_BF (specbind_tag) kind : CHAR_BIT;
3142 /* `where' is not used in the case of SPECPDL_LET. */ 3213 /* `where' is not used in the case of SPECPDL_LET. */
3143 Lisp_Object symbol, old_value, where; 3214 Lisp_Object symbol, old_value, where;
3215 /* Normally this is unused; but it is set to the symbol's
3216 current value when a thread is swapped out. */
3217 Lisp_Object saved_value;
3144 } let; 3218 } let;
3145 struct { 3219 struct {
3146 ENUM_BF (specbind_tag) kind : CHAR_BIT; 3220 ENUM_BF (specbind_tag) kind : CHAR_BIT;
@@ -3151,9 +3225,10 @@ union specbinding
3151 } bt; 3225 } bt;
3152 }; 3226 };
3153 3227
3154extern union specbinding *specpdl; 3228/* These 3 are defined as macros in thread.h. */
3155extern union specbinding *specpdl_ptr; 3229/* extern union specbinding *specpdl; */
3156extern ptrdiff_t specpdl_size; 3230/* extern union specbinding *specpdl_ptr; */
3231/* extern ptrdiff_t specpdl_size; */
3157 3232
3158INLINE ptrdiff_t 3233INLINE ptrdiff_t
3159SPECPDL_INDEX (void) 3234SPECPDL_INDEX (void)
@@ -3204,18 +3279,15 @@ struct handler
3204 /* Most global vars are reset to their value via the specpdl mechanism, 3279 /* Most global vars are reset to their value via the specpdl mechanism,
3205 but a few others are handled by storing their value here. */ 3280 but a few others are handled by storing their value here. */
3206 sys_jmp_buf jmp; 3281 sys_jmp_buf jmp;
3207 EMACS_INT lisp_eval_depth; 3282 EMACS_INT f_lisp_eval_depth;
3208 ptrdiff_t pdlcount; 3283 ptrdiff_t pdlcount;
3209 int poll_suppress_count; 3284 int poll_suppress_count;
3210 int interrupt_input_blocked; 3285 int interrupt_input_blocked;
3286 struct byte_stack *byte_stack;
3211}; 3287};
3212 3288
3213extern Lisp_Object memory_signal_data; 3289extern Lisp_Object memory_signal_data;
3214 3290
3215/* An address near the bottom of the stack.
3216 Tells GC how to save a copy of the stack. */
3217extern char *stack_bottom;
3218
3219/* Check quit-flag and quit if it is non-nil. 3291/* Check quit-flag and quit if it is non-nil.
3220 Typing C-g does not directly cause a quit; it only sets Vquit_flag. 3292 Typing C-g does not directly cause a quit; it only sets Vquit_flag.
3221 So the program needs to do QUIT at times when it is safe to quit. 3293 So the program needs to do QUIT at times when it is safe to quit.
@@ -3617,9 +3689,10 @@ extern void refill_memory_reserve (void);
3617#endif 3689#endif
3618extern void alloc_unexec_pre (void); 3690extern void alloc_unexec_pre (void);
3619extern void alloc_unexec_post (void); 3691extern void alloc_unexec_post (void);
3692extern void mark_stack (char *, char *);
3693extern void flush_stack_call_func (void (*func) (void *arg), void *arg);
3620extern const char *pending_malloc_warning; 3694extern const char *pending_malloc_warning;
3621extern Lisp_Object zero_vector; 3695extern Lisp_Object zero_vector;
3622extern Lisp_Object *stack_base;
3623extern EMACS_INT consing_since_gc; 3696extern EMACS_INT consing_since_gc;
3624extern EMACS_INT gc_relative_threshold; 3697extern EMACS_INT gc_relative_threshold;
3625extern EMACS_INT memory_full_cons_threshold; 3698extern EMACS_INT memory_full_cons_threshold;
@@ -3881,7 +3954,6 @@ extern Lisp_Object Vautoload_queue;
3881extern Lisp_Object Vrun_hooks; 3954extern Lisp_Object Vrun_hooks;
3882extern Lisp_Object Vsignaling_function; 3955extern Lisp_Object Vsignaling_function;
3883extern Lisp_Object inhibit_lisp_code; 3956extern Lisp_Object inhibit_lisp_code;
3884extern struct handler *handlerlist;
3885 3957
3886/* To run a normal hook, use the appropriate function from the list below. 3958/* To run a normal hook, use the appropriate function from the list below.
3887 The calling convention: 3959 The calling convention:
@@ -3939,6 +4011,8 @@ extern void clear_unwind_protect (ptrdiff_t);
3939extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object); 4011extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object);
3940extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *); 4012extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *);
3941extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object); 4013extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object);
4014extern void rebind_for_thread_switch (void);
4015extern void unbind_for_thread_switch (struct thread_state *);
3942extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); 4016extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
3943extern _Noreturn void verror (const char *, va_list) 4017extern _Noreturn void verror (const char *, va_list)
3944 ATTRIBUTE_FORMAT_PRINTF (1, 0); 4018 ATTRIBUTE_FORMAT_PRINTF (1, 0);
@@ -3955,7 +4029,7 @@ extern void init_eval (void);
3955extern void syms_of_eval (void); 4029extern void syms_of_eval (void);
3956extern void unwind_body (Lisp_Object); 4030extern void unwind_body (Lisp_Object);
3957extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t); 4031extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t);
3958extern void mark_specpdl (void); 4032extern void mark_specpdl (union specbinding *first, union specbinding *ptr);
3959extern void get_backtrace (Lisp_Object array); 4033extern void get_backtrace (Lisp_Object array);
3960Lisp_Object backtrace_top_function (void); 4034Lisp_Object backtrace_top_function (void);
3961extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol); 4035extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
@@ -3970,6 +4044,9 @@ extern void module_init (void);
3970extern void syms_of_module (void); 4044extern void syms_of_module (void);
3971#endif 4045#endif
3972 4046
4047/* Defined in thread.c. */
4048extern void mark_threads (void);
4049
3973/* Defined in editfns.c. */ 4050/* Defined in editfns.c. */
3974extern void insert1 (Lisp_Object); 4051extern void insert1 (Lisp_Object);
3975extern Lisp_Object save_excursion_save (void); 4052extern Lisp_Object save_excursion_save (void);
@@ -4250,6 +4327,7 @@ extern int read_bytecode_char (bool);
4250 4327
4251/* Defined in bytecode.c. */ 4328/* Defined in bytecode.c. */
4252extern void syms_of_bytecode (void); 4329extern void syms_of_bytecode (void);
4330extern void relocate_byte_stack (struct byte_stack *);
4253extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, 4331extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object,
4254 Lisp_Object, ptrdiff_t, Lisp_Object *); 4332 Lisp_Object, ptrdiff_t, Lisp_Object *);
4255extern Lisp_Object get_byte_code_arity (Lisp_Object); 4333extern Lisp_Object get_byte_code_arity (Lisp_Object);
diff --git a/src/print.c b/src/print.c
index f3db6748d03..6c350fc86aa 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1911,6 +1911,42 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
1911 } 1911 }
1912 printchar ('>', printcharfun); 1912 printchar ('>', printcharfun);
1913 } 1913 }
1914 else if (THREADP (obj))
1915 {
1916 print_c_string ("#<thread ", printcharfun);
1917 if (STRINGP (XTHREAD (obj)->name))
1918 print_string (XTHREAD (obj)->name, printcharfun);
1919 else
1920 {
1921 int len = sprintf (buf, "%p", XTHREAD (obj));
1922 strout (buf, len, len, printcharfun);
1923 }
1924 printchar ('>', printcharfun);
1925 }
1926 else if (MUTEXP (obj))
1927 {
1928 print_c_string ("#<mutex ", printcharfun);
1929 if (STRINGP (XMUTEX (obj)->name))
1930 print_string (XMUTEX (obj)->name, printcharfun);
1931 else
1932 {
1933 int len = sprintf (buf, "%p", XMUTEX (obj));
1934 strout (buf, len, len, printcharfun);
1935 }
1936 printchar ('>', printcharfun);
1937 }
1938 else if (CONDVARP (obj))
1939 {
1940 print_c_string ("#<condvar ", printcharfun);
1941 if (STRINGP (XCONDVAR (obj)->name))
1942 print_string (XCONDVAR (obj)->name, printcharfun);
1943 else
1944 {
1945 int len = sprintf (buf, "%p", XCONDVAR (obj));
1946 strout (buf, len, len, printcharfun);
1947 }
1948 printchar ('>', printcharfun);
1949 }
1914 else 1950 else
1915 { 1951 {
1916 ptrdiff_t size = ASIZE (obj); 1952 ptrdiff_t size = ASIZE (obj);
diff --git a/src/process.c b/src/process.c
index 8ab73bd9ae6..31c9d74a3f2 100644
--- a/src/process.c
+++ b/src/process.c
@@ -138,7 +138,7 @@ static struct rlimit nofile_limit;
138 138
139#ifdef WINDOWSNT 139#ifdef WINDOWSNT
140extern int sys_select (int, fd_set *, fd_set *, fd_set *, 140extern int sys_select (int, fd_set *, fd_set *, fd_set *,
141 struct timespec *, void *); 141 const struct timespec *, const sigset_t *);
142#endif 142#endif
143 143
144/* Work around GCC 4.3.0 bug with strict overflow checking; see 144/* Work around GCC 4.3.0 bug with strict overflow checking; see
@@ -260,36 +260,11 @@ static int read_process_output (Lisp_Object, int);
260static void create_pty (Lisp_Object); 260static void create_pty (Lisp_Object);
261static void exec_sentinel (Lisp_Object, Lisp_Object); 261static void exec_sentinel (Lisp_Object, Lisp_Object);
262 262
263/* Mask of bits indicating the descriptors that we wait for input on. */
264
265static fd_set input_wait_mask;
266
267/* Mask that excludes keyboard input descriptor(s). */
268
269static fd_set non_keyboard_wait_mask;
270
271/* Mask that excludes process input descriptor(s). */
272
273static fd_set non_process_wait_mask;
274
275/* Mask for selecting for write. */
276
277static fd_set write_mask;
278
279/* Mask of bits indicating the descriptors that we wait for connect to
280 complete on. Once they complete, they are removed from this mask
281 and added to the input_wait_mask and non_keyboard_wait_mask. */
282
283static fd_set connect_wait_mask;
284
285/* Number of bits set in connect_wait_mask. */ 263/* Number of bits set in connect_wait_mask. */
286static int num_pending_connects; 264static int num_pending_connects;
287 265
288/* The largest descriptor currently in use for a process object; -1 if none. */ 266/* The largest descriptor currently in use; -1 if none. */
289static int max_process_desc; 267static int max_desc;
290
291/* The largest descriptor currently in use for input; -1 if none. */
292static int max_input_desc;
293 268
294/* Set the external socket descriptor for Emacs to use when 269/* Set the external socket descriptor for Emacs to use when
295 `make-network-process' is called with a non-nil 270 `make-network-process' is called with a non-nil
@@ -384,6 +359,11 @@ pset_mark (struct Lisp_Process *p, Lisp_Object val)
384 p->mark = val; 359 p->mark = val;
385} 360}
386static void 361static void
362pset_thread (struct Lisp_Process *p, Lisp_Object val)
363{
364 p->thread = val;
365}
366static void
387pset_name (struct Lisp_Process *p, Lisp_Object val) 367pset_name (struct Lisp_Process *p, Lisp_Object val)
388{ 368{
389 p->name = val; 369 p->name = val;
@@ -426,13 +406,34 @@ make_lisp_proc (struct Lisp_Process *p)
426 return make_lisp_ptr (p, Lisp_Vectorlike); 406 return make_lisp_ptr (p, Lisp_Vectorlike);
427} 407}
428 408
409enum fd_bits
410{
411 /* Read from file descriptor. */
412 FOR_READ = 1,
413 /* Write to file descriptor. */
414 FOR_WRITE = 2,
415 /* This descriptor refers to a keyboard. Only valid if FOR_READ is
416 set. */
417 KEYBOARD_FD = 4,
418 /* This descriptor refers to a process. */
419 PROCESS_FD = 8,
420 /* A non-blocking connect. Only valid if FOR_WRITE is set. */
421 NON_BLOCKING_CONNECT_FD = 16
422};
423
429static struct fd_callback_data 424static struct fd_callback_data
430{ 425{
431 fd_callback func; 426 fd_callback func;
432 void *data; 427 void *data;
433#define FOR_READ 1 428 /* Flags from enum fd_bits. */
434#define FOR_WRITE 2 429 int flags;
435 int condition; /* Mask of the defines above. */ 430 /* If this fd is locked to a certain thread, this points to it.
431 Otherwise, this is NULL. If an fd is locked to a thread, then
432 only that thread is permitted to wait on it. */
433 struct thread_state *thread;
434 /* If this fd is currently being selected on by a thread, this
435 points to the thread. Otherwise it is NULL. */
436 struct thread_state *waiting_thread;
436} fd_callback_info[FD_SETSIZE]; 437} fd_callback_info[FD_SETSIZE];
437 438
438 439
@@ -446,7 +447,25 @@ add_read_fd (int fd, fd_callback func, void *data)
446 447
447 fd_callback_info[fd].func = func; 448 fd_callback_info[fd].func = func;
448 fd_callback_info[fd].data = data; 449 fd_callback_info[fd].data = data;
449 fd_callback_info[fd].condition |= FOR_READ; 450}
451
452static void
453add_non_keyboard_read_fd (int fd)
454{
455 eassert (fd >= 0 && fd < FD_SETSIZE);
456 eassert (fd_callback_info[fd].func == NULL);
457
458 fd_callback_info[fd].flags &= ~KEYBOARD_FD;
459 fd_callback_info[fd].flags |= FOR_READ;
460 if (fd > max_desc)
461 max_desc = fd;
462}
463
464static void
465add_process_read_fd (int fd)
466{
467 add_non_keyboard_read_fd (fd);
468 fd_callback_info[fd].flags |= PROCESS_FD;
450} 469}
451 470
452/* Stop monitoring file descriptor FD for when read is possible. */ 471/* Stop monitoring file descriptor FD for when read is possible. */
@@ -456,8 +475,7 @@ delete_read_fd (int fd)
456{ 475{
457 delete_keyboard_wait_descriptor (fd); 476 delete_keyboard_wait_descriptor (fd);
458 477
459 fd_callback_info[fd].condition &= ~FOR_READ; 478 if (fd_callback_info[fd].flags == 0)
460 if (fd_callback_info[fd].condition == 0)
461 { 479 {
462 fd_callback_info[fd].func = 0; 480 fd_callback_info[fd].func = 0;
463 fd_callback_info[fd].data = 0; 481 fd_callback_info[fd].data = 0;
@@ -470,28 +488,39 @@ delete_read_fd (int fd)
470void 488void
471add_write_fd (int fd, fd_callback func, void *data) 489add_write_fd (int fd, fd_callback func, void *data)
472{ 490{
473 FD_SET (fd, &write_mask); 491 eassert (fd >= 0 && fd < FD_SETSIZE);
474 if (fd > max_input_desc)
475 max_input_desc = fd;
476 492
477 fd_callback_info[fd].func = func; 493 fd_callback_info[fd].func = func;
478 fd_callback_info[fd].data = data; 494 fd_callback_info[fd].data = data;
479 fd_callback_info[fd].condition |= FOR_WRITE; 495 fd_callback_info[fd].flags |= FOR_WRITE;
496 if (fd > max_desc)
497 max_desc = fd;
480} 498}
481 499
482/* FD is no longer an input descriptor; update max_input_desc accordingly. */ 500static void
501add_non_blocking_write_fd (int fd)
502{
503 eassert (fd >= 0 && fd < FD_SETSIZE);
504 eassert (fd_callback_info[fd].func == NULL);
505
506 fd_callback_info[fd].flags |= FOR_WRITE | NON_BLOCKING_CONNECT_FD;
507 if (fd > max_desc)
508 max_desc = fd;
509 ++num_pending_connects;
510}
483 511
484static void 512static void
485delete_input_desc (int fd) 513recompute_max_desc (void)
486{ 514{
487 if (fd == max_input_desc) 515 int fd;
488 {
489 do
490 fd--;
491 while (0 <= fd && ! (FD_ISSET (fd, &input_wait_mask)
492 || FD_ISSET (fd, &write_mask)));
493 516
494 max_input_desc = fd; 517 for (fd = max_desc; fd >= 0; --fd)
518 {
519 if (fd_callback_info[fd].flags != 0)
520 {
521 max_desc = fd;
522 break;
523 }
495 } 524 }
496} 525}
497 526
@@ -500,13 +529,121 @@ delete_input_desc (int fd)
500void 529void
501delete_write_fd (int fd) 530delete_write_fd (int fd)
502{ 531{
503 FD_CLR (fd, &write_mask); 532 if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0)
504 fd_callback_info[fd].condition &= ~FOR_WRITE; 533 {
505 if (fd_callback_info[fd].condition == 0) 534 if (--num_pending_connects < 0)
535 emacs_abort ();
536 }
537 fd_callback_info[fd].flags &= ~(FOR_WRITE | NON_BLOCKING_CONNECT_FD);
538 if (fd_callback_info[fd].flags == 0)
506 { 539 {
507 fd_callback_info[fd].func = 0; 540 fd_callback_info[fd].func = 0;
508 fd_callback_info[fd].data = 0; 541 fd_callback_info[fd].data = 0;
509 delete_input_desc (fd); 542
543 if (fd == max_desc)
544 recompute_max_desc ();
545 }
546}
547
548static void
549compute_input_wait_mask (fd_set *mask)
550{
551 int fd;
552
553 FD_ZERO (mask);
554 for (fd = 0; fd <= max_desc; ++fd)
555 {
556 if (fd_callback_info[fd].thread != NULL
557 && fd_callback_info[fd].thread != current_thread)
558 continue;
559 if (fd_callback_info[fd].waiting_thread != NULL
560 && fd_callback_info[fd].waiting_thread != current_thread)
561 continue;
562 if ((fd_callback_info[fd].flags & FOR_READ) != 0)
563 {
564 FD_SET (fd, mask);
565 fd_callback_info[fd].waiting_thread = current_thread;
566 }
567 }
568}
569
570static void
571compute_non_process_wait_mask (fd_set *mask)
572{
573 int fd;
574
575 FD_ZERO (mask);
576 for (fd = 0; fd <= max_desc; ++fd)
577 {
578 if (fd_callback_info[fd].thread != NULL
579 && fd_callback_info[fd].thread != current_thread)
580 continue;
581 if (fd_callback_info[fd].waiting_thread != NULL
582 && fd_callback_info[fd].waiting_thread != current_thread)
583 continue;
584 if ((fd_callback_info[fd].flags & FOR_READ) != 0
585 && (fd_callback_info[fd].flags & PROCESS_FD) == 0)
586 {
587 FD_SET (fd, mask);
588 fd_callback_info[fd].waiting_thread = current_thread;
589 }
590 }
591}
592
593static void
594compute_non_keyboard_wait_mask (fd_set *mask)
595{
596 int fd;
597
598 FD_ZERO (mask);
599 for (fd = 0; fd <= max_desc; ++fd)
600 {
601 if (fd_callback_info[fd].thread != NULL
602 && fd_callback_info[fd].thread != current_thread)
603 continue;
604 if (fd_callback_info[fd].waiting_thread != NULL
605 && fd_callback_info[fd].waiting_thread != current_thread)
606 continue;
607 if ((fd_callback_info[fd].flags & FOR_READ) != 0
608 && (fd_callback_info[fd].flags & KEYBOARD_FD) == 0)
609 {
610 FD_SET (fd, mask);
611 fd_callback_info[fd].waiting_thread = current_thread;
612 }
613 }
614}
615
616static void
617compute_write_mask (fd_set *mask)
618{
619 int fd;
620
621 FD_ZERO (mask);
622 for (fd = 0; fd <= max_desc; ++fd)
623 {
624 if (fd_callback_info[fd].thread != NULL
625 && fd_callback_info[fd].thread != current_thread)
626 continue;
627 if (fd_callback_info[fd].waiting_thread != NULL
628 && fd_callback_info[fd].waiting_thread != current_thread)
629 continue;
630 if ((fd_callback_info[fd].flags & FOR_WRITE) != 0)
631 {
632 FD_SET (fd, mask);
633 fd_callback_info[fd].waiting_thread = current_thread;
634 }
635 }
636}
637
638static void
639clear_waiting_thread_info (void)
640{
641 int fd;
642
643 for (fd = 0; fd <= max_desc; ++fd)
644 {
645 if (fd_callback_info[fd].waiting_thread == current_thread)
646 fd_callback_info[fd].waiting_thread = NULL;
510 } 647 }
511} 648}
512 649
@@ -716,6 +853,7 @@ make_process (Lisp_Object name)
716 Lisp data to nil, so do it only for slots which should not be nil. */ 853 Lisp data to nil, so do it only for slots which should not be nil. */
717 pset_status (p, Qrun); 854 pset_status (p, Qrun);
718 pset_mark (p, Fmake_marker ()); 855 pset_mark (p, Fmake_marker ());
856 pset_thread (p, Fcurrent_thread ());
719 857
720 /* Initialize non-Lisp data. Note that allocate_process zeroes out all 858 /* Initialize non-Lisp data. Note that allocate_process zeroes out all
721 non-Lisp data, so do it only for slots which should not be zero. */ 859 non-Lisp data, so do it only for slots which should not be zero. */
@@ -764,6 +902,27 @@ remove_process (register Lisp_Object proc)
764 deactivate_process (proc); 902 deactivate_process (proc);
765} 903}
766 904
905void
906update_processes_for_thread_death (Lisp_Object dying_thread)
907{
908 Lisp_Object pair;
909
910 for (pair = Vprocess_alist; !NILP (pair); pair = XCDR (pair))
911 {
912 Lisp_Object process = XCDR (XCAR (pair));
913 if (EQ (XPROCESS (process)->thread, dying_thread))
914 {
915 struct Lisp_Process *proc = XPROCESS (process);
916
917 pset_thread (proc, Qnil);
918 if (proc->infd >= 0)
919 fd_callback_info[proc->infd].thread = NULL;
920 if (proc->outfd >= 0)
921 fd_callback_info[proc->outfd].thread = NULL;
922 }
923 }
924}
925
767#ifdef HAVE_GETADDRINFO_A 926#ifdef HAVE_GETADDRINFO_A
768static void 927static void
769free_dns_request (Lisp_Object proc) 928free_dns_request (Lisp_Object proc)
@@ -1066,17 +1225,11 @@ static void
1066set_process_filter_masks (struct Lisp_Process *p) 1225set_process_filter_masks (struct Lisp_Process *p)
1067{ 1226{
1068 if (EQ (p->filter, Qt) && !EQ (p->status, Qlisten)) 1227 if (EQ (p->filter, Qt) && !EQ (p->status, Qlisten))
1069 { 1228 delete_read_fd (p->infd);
1070 FD_CLR (p->infd, &input_wait_mask);
1071 FD_CLR (p->infd, &non_keyboard_wait_mask);
1072 }
1073 else if (EQ (p->filter, Qt) 1229 else if (EQ (p->filter, Qt)
1074 /* Network or serial process not stopped: */ 1230 /* Network or serial process not stopped: */
1075 && !EQ (p->command, Qt)) 1231 && !EQ (p->command, Qt))
1076 { 1232 add_process_read_fd (p->infd);
1077 FD_SET (p->infd, &input_wait_mask);
1078 FD_SET (p->infd, &non_keyboard_wait_mask);
1079 }
1080} 1233}
1081 1234
1082DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter, 1235DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter,
@@ -1163,6 +1316,44 @@ See `set-process-sentinel' for more info on sentinels. */)
1163 return XPROCESS (process)->sentinel; 1316 return XPROCESS (process)->sentinel;
1164} 1317}
1165 1318
1319DEFUN ("set-process-thread", Fset_process_thread, Sset_process_thread,
1320 2, 2, 0,
1321 doc: /* Set the locking thread of PROCESS to be THREAD.
1322If THREAD is nil, the process is unlocked. */)
1323 (Lisp_Object process, Lisp_Object thread)
1324{
1325 struct Lisp_Process *proc;
1326 struct thread_state *tstate;
1327
1328 CHECK_PROCESS (process);
1329 if (NILP (thread))
1330 tstate = NULL;
1331 else
1332 {
1333 CHECK_THREAD (thread);
1334 tstate = XTHREAD (thread);
1335 }
1336
1337 proc = XPROCESS (process);
1338 pset_thread (proc, thread);
1339 if (proc->infd >= 0)
1340 fd_callback_info[proc->infd].thread = tstate;
1341 if (proc->outfd >= 0)
1342 fd_callback_info[proc->outfd].thread = tstate;
1343
1344 return thread;
1345}
1346
1347DEFUN ("process-thread", Fprocess_thread, Sprocess_thread,
1348 1, 1, 0,
1349 doc: /* Ret the locking thread of PROCESS.
1350If PROCESS is unlocked, this function returns nil. */)
1351 (Lisp_Object process)
1352{
1353 CHECK_PROCESS (process);
1354 return XPROCESS (process)->thread;
1355}
1356
1166DEFUN ("set-process-window-size", Fset_process_window_size, 1357DEFUN ("set-process-window-size", Fset_process_window_size,
1167 Sset_process_window_size, 3, 3, 0, 1358 Sset_process_window_size, 3, 3, 0,
1168 doc: /* Tell PROCESS that it has logical window size WIDTH by HEIGHT. 1359 doc: /* Tell PROCESS that it has logical window size WIDTH by HEIGHT.
@@ -1840,13 +2031,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
1840 pset_status (p, Qrun); 2031 pset_status (p, Qrun);
1841 2032
1842 if (!EQ (p->command, Qt)) 2033 if (!EQ (p->command, Qt))
1843 { 2034 add_process_read_fd (inchannel);
1844 FD_SET (inchannel, &input_wait_mask);
1845 FD_SET (inchannel, &non_keyboard_wait_mask);
1846 }
1847
1848 if (inchannel > max_process_desc)
1849 max_process_desc = inchannel;
1850 2035
1851 /* This may signal an error. */ 2036 /* This may signal an error. */
1852 setup_process_coding_systems (process); 2037 setup_process_coding_systems (process);
@@ -2079,10 +2264,7 @@ create_pty (Lisp_Object process)
2079 pset_status (p, Qrun); 2264 pset_status (p, Qrun);
2080 setup_process_coding_systems (process); 2265 setup_process_coding_systems (process);
2081 2266
2082 FD_SET (pty_fd, &input_wait_mask); 2267 add_process_read_fd (pty_fd);
2083 FD_SET (pty_fd, &non_keyboard_wait_mask);
2084 if (pty_fd > max_process_desc)
2085 max_process_desc = pty_fd;
2086 2268
2087 pset_tty_name (p, build_string (pty_name)); 2269 pset_tty_name (p, build_string (pty_name));
2088 } 2270 }
@@ -2166,8 +2348,8 @@ usage: (make-pipe-process &rest ARGS) */)
2166 p->infd = inchannel; 2348 p->infd = inchannel;
2167 p->outfd = outchannel; 2349 p->outfd = outchannel;
2168 2350
2169 if (inchannel > max_process_desc) 2351 if (inchannel > max_desc)
2170 max_process_desc = inchannel; 2352 max_desc = inchannel;
2171 2353
2172 buffer = Fplist_get (contact, QCbuffer); 2354 buffer = Fplist_get (contact, QCbuffer);
2173 if (NILP (buffer)) 2355 if (NILP (buffer))
@@ -2188,10 +2370,7 @@ usage: (make-pipe-process &rest ARGS) */)
2188 eassert (! p->pty_flag); 2370 eassert (! p->pty_flag);
2189 2371
2190 if (!EQ (p->command, Qt)) 2372 if (!EQ (p->command, Qt))
2191 { 2373 add_process_read_fd (inchannel);
2192 FD_SET (inchannel, &input_wait_mask);
2193 FD_SET (inchannel, &non_keyboard_wait_mask);
2194 }
2195 p->adaptive_read_buffering 2374 p->adaptive_read_buffering
2196 = (NILP (Vprocess_adaptive_read_buffering) ? 0 2375 = (NILP (Vprocess_adaptive_read_buffering) ? 0
2197 : EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2); 2376 : EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2);
@@ -2904,8 +3083,8 @@ usage: (make-serial-process &rest ARGS) */)
2904 p->open_fd[SUBPROCESS_STDIN] = fd; 3083 p->open_fd[SUBPROCESS_STDIN] = fd;
2905 p->infd = fd; 3084 p->infd = fd;
2906 p->outfd = fd; 3085 p->outfd = fd;
2907 if (fd > max_process_desc) 3086 if (fd > max_desc)
2908 max_process_desc = fd; 3087 max_desc = fd;
2909 chan_process[fd] = proc; 3088 chan_process[fd] = proc;
2910 3089
2911 buffer = Fplist_get (contact, QCbuffer); 3090 buffer = Fplist_get (contact, QCbuffer);
@@ -2927,10 +3106,7 @@ usage: (make-serial-process &rest ARGS) */)
2927 eassert (! p->pty_flag); 3106 eassert (! p->pty_flag);
2928 3107
2929 if (!EQ (p->command, Qt)) 3108 if (!EQ (p->command, Qt))
2930 { 3109 add_process_read_fd (fd);
2931 FD_SET (fd, &input_wait_mask);
2932 FD_SET (fd, &non_keyboard_wait_mask);
2933 }
2934 3110
2935 if (BUFFERP (buffer)) 3111 if (BUFFERP (buffer))
2936 { 3112 {
@@ -3102,7 +3278,7 @@ finish_after_tls_connection (Lisp_Object proc)
3102 pset_status (p, Qfailed); 3278 pset_status (p, Qfailed);
3103 deactivate_process (proc); 3279 deactivate_process (proc);
3104 } 3280 }
3105 else if (! FD_ISSET (p->outfd, &connect_wait_mask)) 3281 else if ((fd_callback_info[p->outfd].flags & NON_BLOCKING_CONNECT_FD) == 0)
3106 { 3282 {
3107 /* If we cleared the connection wait mask before we did the TLS 3283 /* If we cleared the connection wait mask before we did the TLS
3108 setup, then we have to say that the process is finally "open" 3284 setup, then we have to say that the process is finally "open"
@@ -3412,25 +3588,18 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
3412 if (! (connecting_status (p->status) 3588 if (! (connecting_status (p->status)
3413 && EQ (XCDR (p->status), addrinfos))) 3589 && EQ (XCDR (p->status), addrinfos)))
3414 pset_status (p, Fcons (Qconnect, addrinfos)); 3590 pset_status (p, Fcons (Qconnect, addrinfos));
3415 if (!FD_ISSET (inch, &connect_wait_mask)) 3591 if ((fd_callback_info[inch].flags & NON_BLOCKING_CONNECT_FD) == 0)
3416 { 3592 add_non_blocking_write_fd (inch);
3417 FD_SET (inch, &connect_wait_mask);
3418 FD_SET (inch, &write_mask);
3419 num_pending_connects++;
3420 }
3421 } 3593 }
3422 else 3594 else
3423 /* A server may have a client filter setting of Qt, but it must 3595 /* A server may have a client filter setting of Qt, but it must
3424 still listen for incoming connects unless it is stopped. */ 3596 still listen for incoming connects unless it is stopped. */
3425 if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt)) 3597 if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt))
3426 || (EQ (p->status, Qlisten) && NILP (p->command))) 3598 || (EQ (p->status, Qlisten) && NILP (p->command)))
3427 { 3599 add_process_read_fd (inch);
3428 FD_SET (inch, &input_wait_mask);
3429 FD_SET (inch, &non_keyboard_wait_mask);
3430 }
3431 3600
3432 if (inch > max_process_desc) 3601 if (inch > max_desc)
3433 max_process_desc = inch; 3602 max_desc = inch;
3434 3603
3435 /* Set up the masks based on the process filter. */ 3604 /* Set up the masks based on the process filter. */
3436 set_process_filter_masks (p); 3605 set_process_filter_masks (p);
@@ -4361,26 +4530,11 @@ deactivate_process (Lisp_Object proc)
4361 } 4530 }
4362#endif 4531#endif
4363 chan_process[inchannel] = Qnil; 4532 chan_process[inchannel] = Qnil;
4364 FD_CLR (inchannel, &input_wait_mask); 4533 delete_read_fd (inchannel);
4365 FD_CLR (inchannel, &non_keyboard_wait_mask); 4534 if ((fd_callback_info[inchannel].flags & NON_BLOCKING_CONNECT_FD) != 0)
4366 if (FD_ISSET (inchannel, &connect_wait_mask)) 4535 delete_write_fd (inchannel);
4367 { 4536 if (inchannel == max_desc)
4368 FD_CLR (inchannel, &connect_wait_mask); 4537 recompute_max_desc ();
4369 FD_CLR (inchannel, &write_mask);
4370 if (--num_pending_connects < 0)
4371 emacs_abort ();
4372 }
4373 if (inchannel == max_process_desc)
4374 {
4375 /* We just closed the highest-numbered process input descriptor,
4376 so recompute the highest-numbered one now. */
4377 int i = inchannel;
4378 do
4379 i--;
4380 while (0 <= i && NILP (chan_process[i]));
4381
4382 max_process_desc = i;
4383 }
4384 } 4538 }
4385} 4539}
4386 4540
@@ -4409,7 +4563,18 @@ is nil, from any process) before the timeout expired. */)
4409 int nsecs; 4563 int nsecs;
4410 4564
4411 if (! NILP (process)) 4565 if (! NILP (process))
4412 CHECK_PROCESS (process); 4566 {
4567 struct Lisp_Process *procp;
4568
4569 CHECK_PROCESS (process);
4570 procp = XPROCESS (process);
4571
4572 /* Can't wait for a process that is dedicated to a different
4573 thread. */
4574 if (!EQ (procp->thread, Qnil) && !EQ (procp->thread, Fcurrent_thread ()))
4575 error ("Attempt to accept output from process %s locked to thread %s",
4576 SDATA (procp->name), SDATA (XTHREAD (procp->thread)->name));
4577 }
4413 else 4578 else
4414 just_this_one = Qnil; 4579 just_this_one = Qnil;
4415 4580
@@ -4627,13 +4792,9 @@ server_accept_connection (Lisp_Object server, int channel)
4627 4792
4628 /* Client processes for accepted connections are not stopped initially. */ 4793 /* Client processes for accepted connections are not stopped initially. */
4629 if (!EQ (p->filter, Qt)) 4794 if (!EQ (p->filter, Qt))
4630 { 4795 add_process_read_fd (s);
4631 FD_SET (s, &input_wait_mask); 4796 if (s > max_desc)
4632 FD_SET (s, &non_keyboard_wait_mask); 4797 max_desc = s;
4633 }
4634
4635 if (s > max_process_desc)
4636 max_process_desc = s;
4637 4798
4638 /* Setup coding system for new process based on server process. 4799 /* Setup coding system for new process based on server process.
4639 This seems to be the proper thing to do, as the coding system 4800 This seems to be the proper thing to do, as the coding system
@@ -4746,20 +4907,10 @@ wait_for_tls_negotiation (Lisp_Object process)
4746#endif 4907#endif
4747} 4908}
4748 4909
4749/* This variable is different from waiting_for_input in keyboard.c.
4750 It is used to communicate to a lisp process-filter/sentinel (via the
4751 function Fwaiting_for_user_input_p below) whether Emacs was waiting
4752 for user-input when that process-filter was called.
4753 waiting_for_input cannot be used as that is by definition 0 when
4754 lisp code is being evalled.
4755 This is also used in record_asynch_buffer_change.
4756 For that purpose, this must be 0
4757 when not inside wait_reading_process_output. */
4758static int waiting_for_user_input_p;
4759
4760static void 4910static void
4761wait_reading_process_output_unwind (int data) 4911wait_reading_process_output_unwind (int data)
4762{ 4912{
4913 clear_waiting_thread_info ();
4763 waiting_for_user_input_p = data; 4914 waiting_for_user_input_p = data;
4764} 4915}
4765 4916
@@ -4832,6 +4983,10 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
4832 /* Close to the current time if known, an invalid timespec otherwise. */ 4983 /* Close to the current time if known, an invalid timespec otherwise. */
4833 struct timespec now = invalid_timespec (); 4984 struct timespec now = invalid_timespec ();
4834 4985
4986 eassert (wait_proc == NULL
4987 || EQ (wait_proc->thread, Qnil)
4988 || XTHREAD (wait_proc->thread) == current_thread);
4989
4835 FD_ZERO (&Available); 4990 FD_ZERO (&Available);
4836 FD_ZERO (&Writeok); 4991 FD_ZERO (&Writeok);
4837 4992
@@ -5004,14 +5159,14 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5004 if (kbd_on_hold_p ()) 5159 if (kbd_on_hold_p ())
5005 FD_ZERO (&Atemp); 5160 FD_ZERO (&Atemp);
5006 else 5161 else
5007 Atemp = input_wait_mask; 5162 compute_input_wait_mask (&Atemp);
5008 Ctemp = write_mask; 5163 compute_write_mask (&Ctemp);
5009 5164
5010 timeout = make_timespec (0, 0); 5165 timeout = make_timespec (0, 0);
5011 if ((pselect (max (max_process_desc, max_input_desc) + 1, 5166 if ((thread_select (pselect, max_desc + 1,
5012 &Atemp, 5167 &Atemp,
5013 (num_pending_connects > 0 ? &Ctemp : NULL), 5168 (num_pending_connects > 0 ? &Ctemp : NULL),
5014 NULL, &timeout, NULL) 5169 NULL, &timeout, NULL)
5015 <= 0)) 5170 <= 0))
5016 { 5171 {
5017 /* It's okay for us to do this and then continue with 5172 /* It's okay for us to do this and then continue with
@@ -5076,17 +5231,17 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5076 } 5231 }
5077 else if (!NILP (wait_for_cell)) 5232 else if (!NILP (wait_for_cell))
5078 { 5233 {
5079 Available = non_process_wait_mask; 5234 compute_non_process_wait_mask (&Available);
5080 check_delay = 0; 5235 check_delay = 0;
5081 check_write = 0; 5236 check_write = 0;
5082 } 5237 }
5083 else 5238 else
5084 { 5239 {
5085 if (! read_kbd) 5240 if (! read_kbd)
5086 Available = non_keyboard_wait_mask; 5241 compute_non_keyboard_wait_mask (&Available);
5087 else 5242 else
5088 Available = input_wait_mask; 5243 compute_input_wait_mask (&Available);
5089 Writeok = write_mask; 5244 compute_write_mask (&Writeok);
5090 check_delay = wait_proc ? 0 : process_output_delay_count; 5245 check_delay = wait_proc ? 0 : process_output_delay_count;
5091 check_write = true; 5246 check_write = true;
5092 } 5247 }
@@ -5128,7 +5283,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5128 int adaptive_nsecs = timeout.tv_nsec; 5283 int adaptive_nsecs = timeout.tv_nsec;
5129 if (timeout.tv_sec > 0 || adaptive_nsecs > READ_OUTPUT_DELAY_MAX) 5284 if (timeout.tv_sec > 0 || adaptive_nsecs > READ_OUTPUT_DELAY_MAX)
5130 adaptive_nsecs = READ_OUTPUT_DELAY_MAX; 5285 adaptive_nsecs = READ_OUTPUT_DELAY_MAX;
5131 for (channel = 0; check_delay > 0 && channel <= max_process_desc; channel++) 5286 for (channel = 0; check_delay > 0 && channel <= max_desc; channel++)
5132 { 5287 {
5133 proc = chan_process[channel]; 5288 proc = chan_process[channel];
5134 if (NILP (proc)) 5289 if (NILP (proc))
@@ -5187,17 +5342,18 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5187 } 5342 }
5188#endif 5343#endif
5189 5344
5345 nfds = thread_select (
5190#if defined (HAVE_NS) 5346#if defined (HAVE_NS)
5191 nfds = ns_select 5347 ns_select
5192#elif defined (HAVE_GLIB) 5348#elif defined (HAVE_GLIB)
5193 nfds = xg_select 5349 xg_select
5194#else 5350#else
5195 nfds = pselect 5351 pselect
5196#endif 5352#endif
5197 (max (max_process_desc, max_input_desc) + 1, 5353 , max_desc + 1,
5198 &Available, 5354 &Available,
5199 (check_write ? &Writeok : 0), 5355 (check_write ? &Writeok : 0),
5200 NULL, &timeout, NULL); 5356 NULL, &timeout, NULL);
5201 5357
5202#ifdef HAVE_GNUTLS 5358#ifdef HAVE_GNUTLS
5203 /* GnuTLS buffers data internally. In lowat mode it leaves 5359 /* GnuTLS buffers data internally. In lowat mode it leaves
@@ -5381,22 +5537,22 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5381 if (no_avail || nfds == 0) 5537 if (no_avail || nfds == 0)
5382 continue; 5538 continue;
5383 5539
5384 for (channel = 0; channel <= max_input_desc; ++channel) 5540 for (channel = 0; channel <= max_desc; ++channel)
5385 { 5541 {
5386 struct fd_callback_data *d = &fd_callback_info[channel]; 5542 struct fd_callback_data *d = &fd_callback_info[channel];
5387 if (d->func 5543 if (d->func
5388 && ((d->condition & FOR_READ 5544 && ((d->flags & FOR_READ
5389 && FD_ISSET (channel, &Available)) 5545 && FD_ISSET (channel, &Available))
5390 || (d->condition & FOR_WRITE 5546 || ((d->flags & FOR_WRITE)
5391 && FD_ISSET (channel, &write_mask)))) 5547 && FD_ISSET (channel, &Writeok))))
5392 d->func (channel, d->data); 5548 d->func (channel, d->data);
5393 } 5549 }
5394 5550
5395 for (channel = 0; channel <= max_process_desc; channel++) 5551 for (channel = 0; channel <= max_desc; channel++)
5396 { 5552 {
5397 if (FD_ISSET (channel, &Available) 5553 if (FD_ISSET (channel, &Available)
5398 && FD_ISSET (channel, &non_keyboard_wait_mask) 5554 && ((fd_callback_info[channel].flags & (KEYBOARD_FD | PROCESS_FD))
5399 && !FD_ISSET (channel, &non_process_wait_mask)) 5555 == PROCESS_FD))
5400 { 5556 {
5401 int nread; 5557 int nread;
5402 5558
@@ -5461,8 +5617,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5461 5617
5462 /* Clear the descriptor now, so we only raise the 5618 /* Clear the descriptor now, so we only raise the
5463 signal once. */ 5619 signal once. */
5464 FD_CLR (channel, &input_wait_mask); 5620 delete_read_fd (channel);
5465 FD_CLR (channel, &non_keyboard_wait_mask);
5466 5621
5467 if (p->pid == -2) 5622 if (p->pid == -2)
5468 { 5623 {
@@ -5501,14 +5656,12 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5501 } 5656 }
5502 } 5657 }
5503 if (FD_ISSET (channel, &Writeok) 5658 if (FD_ISSET (channel, &Writeok)
5504 && FD_ISSET (channel, &connect_wait_mask)) 5659 && (fd_callback_info[channel].flags
5660 & NON_BLOCKING_CONNECT_FD) != 0)
5505 { 5661 {
5506 struct Lisp_Process *p; 5662 struct Lisp_Process *p;
5507 5663
5508 FD_CLR (channel, &connect_wait_mask); 5664 delete_write_fd (channel);
5509 FD_CLR (channel, &write_mask);
5510 if (--num_pending_connects < 0)
5511 emacs_abort ();
5512 5665
5513 proc = chan_process[channel]; 5666 proc = chan_process[channel];
5514 if (NILP (proc)) 5667 if (NILP (proc))
@@ -5576,10 +5729,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5576 5729
5577 if (0 <= p->infd && !EQ (p->filter, Qt) 5730 if (0 <= p->infd && !EQ (p->filter, Qt)
5578 && !EQ (p->command, Qt)) 5731 && !EQ (p->command, Qt))
5579 { 5732 add_process_read_fd (p->infd);
5580 FD_SET (p->infd, &input_wait_mask);
5581 FD_SET (p->infd, &non_keyboard_wait_mask);
5582 }
5583 } 5733 }
5584 } 5734 }
5585 } /* End for each file descriptor. */ 5735 } /* End for each file descriptor. */
@@ -6550,10 +6700,7 @@ of incoming traffic. */)
6550 p = XPROCESS (process); 6700 p = XPROCESS (process);
6551 if (NILP (p->command) 6701 if (NILP (p->command)
6552 && p->infd >= 0) 6702 && p->infd >= 0)
6553 { 6703 delete_read_fd (p->infd);
6554 FD_CLR (p->infd, &input_wait_mask);
6555 FD_CLR (p->infd, &non_keyboard_wait_mask);
6556 }
6557 pset_command (p, Qt); 6704 pset_command (p, Qt);
6558 return process; 6705 return process;
6559 } 6706 }
@@ -6582,8 +6729,7 @@ traffic. */)
6582 && p->infd >= 0 6729 && p->infd >= 0
6583 && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten))) 6730 && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten)))
6584 { 6731 {
6585 FD_SET (p->infd, &input_wait_mask); 6732 add_process_read_fd (p->infd);
6586 FD_SET (p->infd, &non_keyboard_wait_mask);
6587#ifdef WINDOWSNT 6733#ifdef WINDOWSNT
6588 if (fd_info[ p->infd ].flags & FILE_SERIAL) 6734 if (fd_info[ p->infd ].flags & FILE_SERIAL)
6589 PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR); 6735 PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR);
@@ -6890,10 +7036,7 @@ handle_child_signal (int sig)
6890 7036
6891 /* clear_desc_flag avoids a compiler bug in Microsoft C. */ 7037 /* clear_desc_flag avoids a compiler bug in Microsoft C. */
6892 if (clear_desc_flag) 7038 if (clear_desc_flag)
6893 { 7039 delete_read_fd (p->infd);
6894 FD_CLR (p->infd, &input_wait_mask);
6895 FD_CLR (p->infd, &non_keyboard_wait_mask);
6896 }
6897 } 7040 }
6898 } 7041 }
6899 } 7042 }
@@ -7253,9 +7396,10 @@ keyboard_bit_set (fd_set *mask)
7253{ 7396{
7254 int fd; 7397 int fd;
7255 7398
7256 for (fd = 0; fd <= max_input_desc; fd++) 7399 for (fd = 0; fd <= max_desc; fd++)
7257 if (FD_ISSET (fd, mask) && FD_ISSET (fd, &input_wait_mask) 7400 if (FD_ISSET (fd, mask)
7258 && !FD_ISSET (fd, &non_keyboard_wait_mask)) 7401 && ((fd_callback_info[fd].flags & (FOR_READ | KEYBOARD_FD))
7402 == (FOR_READ | KEYBOARD_FD)))
7259 return 1; 7403 return 1;
7260 7404
7261 return 0; 7405 return 0;
@@ -7492,14 +7636,8 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
7492void 7636void
7493add_timer_wait_descriptor (int fd) 7637add_timer_wait_descriptor (int fd)
7494{ 7638{
7495 FD_SET (fd, &input_wait_mask); 7639 add_read_fd (fd, timerfd_callback, NULL);
7496 FD_SET (fd, &non_keyboard_wait_mask); 7640 fd_callback_info[fd].flags &= ~KEYBOARD_FD;
7497 FD_SET (fd, &non_process_wait_mask);
7498 fd_callback_info[fd].func = timerfd_callback;
7499 fd_callback_info[fd].data = NULL;
7500 fd_callback_info[fd].condition |= FOR_READ;
7501 if (fd > max_input_desc)
7502 max_input_desc = fd;
7503} 7641}
7504 7642
7505#endif /* HAVE_TIMERFD */ 7643#endif /* HAVE_TIMERFD */
@@ -7523,10 +7661,11 @@ void
7523add_keyboard_wait_descriptor (int desc) 7661add_keyboard_wait_descriptor (int desc)
7524{ 7662{
7525#ifdef subprocesses /* Actually means "not MSDOS". */ 7663#ifdef subprocesses /* Actually means "not MSDOS". */
7526 FD_SET (desc, &input_wait_mask); 7664 eassert (desc >= 0 && desc < FD_SETSIZE);
7527 FD_SET (desc, &non_process_wait_mask); 7665 fd_callback_info[desc].flags &= ~PROCESS_FD;
7528 if (desc > max_input_desc) 7666 fd_callback_info[desc].flags |= (FOR_READ | KEYBOARD_FD);
7529 max_input_desc = desc; 7667 if (desc > max_desc)
7668 max_desc = desc;
7530#endif 7669#endif
7531} 7670}
7532 7671
@@ -7536,9 +7675,12 @@ void
7536delete_keyboard_wait_descriptor (int desc) 7675delete_keyboard_wait_descriptor (int desc)
7537{ 7676{
7538#ifdef subprocesses 7677#ifdef subprocesses
7539 FD_CLR (desc, &input_wait_mask); 7678 eassert (desc >= 0 && desc < FD_SETSIZE);
7540 FD_CLR (desc, &non_process_wait_mask); 7679
7541 delete_input_desc (desc); 7680 fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD);
7681
7682 if (desc == max_desc)
7683 recompute_max_desc ();
7542#endif 7684#endif
7543} 7685}
7544 7686
@@ -7819,15 +7961,10 @@ init_process_emacs (int sockfd)
7819 } 7961 }
7820#endif 7962#endif
7821 7963
7822 FD_ZERO (&input_wait_mask);
7823 FD_ZERO (&non_keyboard_wait_mask);
7824 FD_ZERO (&non_process_wait_mask);
7825 FD_ZERO (&write_mask);
7826 max_process_desc = max_input_desc = -1;
7827 external_sock_fd = sockfd; 7964 external_sock_fd = sockfd;
7965 max_desc = -1;
7828 memset (fd_callback_info, 0, sizeof (fd_callback_info)); 7966 memset (fd_callback_info, 0, sizeof (fd_callback_info));
7829 7967
7830 FD_ZERO (&connect_wait_mask);
7831 num_pending_connects = 0; 7968 num_pending_connects = 0;
7832 7969
7833 process_output_delay_count = 0; 7970 process_output_delay_count = 0;
@@ -8027,6 +8164,8 @@ The variable takes effect when `start-process' is called. */);
8027 defsubr (&Sprocess_filter); 8164 defsubr (&Sprocess_filter);
8028 defsubr (&Sset_process_sentinel); 8165 defsubr (&Sset_process_sentinel);
8029 defsubr (&Sprocess_sentinel); 8166 defsubr (&Sprocess_sentinel);
8167 defsubr (&Sset_process_thread);
8168 defsubr (&Sprocess_thread);
8030 defsubr (&Sset_process_window_size); 8169 defsubr (&Sset_process_window_size);
8031 defsubr (&Sset_process_inherit_coding_system_flag); 8170 defsubr (&Sset_process_inherit_coding_system_flag);
8032 defsubr (&Sset_process_query_on_exit_flag); 8171 defsubr (&Sset_process_query_on_exit_flag);
diff --git a/src/process.h b/src/process.h
index 24c628231a0..e497ebc539f 100644
--- a/src/process.h
+++ b/src/process.h
@@ -115,6 +115,9 @@ struct Lisp_Process
115 /* Pipe process attached to the standard error of this process. */ 115 /* Pipe process attached to the standard error of this process. */
116 Lisp_Object stderrproc; 116 Lisp_Object stderrproc;
117 117
118 /* The thread a process is linked to, or nil for any thread. */
119 Lisp_Object thread;
120
118 /* After this point, there are no Lisp_Objects any more. */ 121 /* After this point, there are no Lisp_Objects any more. */
119 /* alloc.c assumes that `pid' is the first such non-Lisp slot. */ 122 /* alloc.c assumes that `pid' is the first such non-Lisp slot. */
120 123
@@ -274,6 +277,8 @@ extern Lisp_Object network_interface_info (Lisp_Object);
274 277
275extern Lisp_Object remove_slash_colon (Lisp_Object); 278extern Lisp_Object remove_slash_colon (Lisp_Object);
276 279
280extern void update_processes_for_thread_death (Lisp_Object);
281
277INLINE_HEADER_END 282INLINE_HEADER_END
278 283
279#endif /* EMACS_PROCESS_H */ 284#endif /* EMACS_PROCESS_H */
diff --git a/src/regex.c b/src/regex.c
index afd0d180316..f1686cf700c 100644
--- a/src/regex.c
+++ b/src/regex.c
@@ -4885,12 +4885,6 @@ re_match (struct re_pattern_buffer *bufp, const char *string,
4885WEAK_ALIAS (__re_match, re_match) 4885WEAK_ALIAS (__re_match, re_match)
4886#endif /* not emacs */ 4886#endif /* not emacs */
4887 4887
4888#ifdef emacs
4889/* In Emacs, this is the string or buffer in which we are matching.
4890 See the declaration in regex.h for details. */
4891Lisp_Object re_match_object;
4892#endif
4893
4894/* re_match_2 matches the compiled pattern in BUFP against the 4888/* re_match_2 matches the compiled pattern in BUFP against the
4895 the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1 4889 the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1
4896 and SIZE2, respectively). We start matching at POS, and stop 4890 and SIZE2, respectively). We start matching at POS, and stop
diff --git a/src/regex.h b/src/regex.h
index 4922440e472..2d720e68f22 100644
--- a/src/regex.h
+++ b/src/regex.h
@@ -171,7 +171,7 @@ typedef unsigned long reg_syntax_t;
171 some interfaces). When a regexp is compiled, the syntax used is 171 some interfaces). When a regexp is compiled, the syntax used is
172 stored in the pattern buffer, so changing this does not affect 172 stored in the pattern buffer, so changing this does not affect
173 already-compiled regexps. */ 173 already-compiled regexps. */
174extern reg_syntax_t re_syntax_options; 174/* extern reg_syntax_t re_syntax_options; */
175 175
176#ifdef emacs 176#ifdef emacs
177# include "lisp.h" 177# include "lisp.h"
@@ -180,8 +180,10 @@ extern reg_syntax_t re_syntax_options;
180 180
181 If the value is a Lisp string object, we are matching text in that 181 If the value is a Lisp string object, we are matching text in that
182 string; if it's nil, we are matching text in the current buffer; if 182 string; if it's nil, we are matching text in the current buffer; if
183 it's t, we are matching text in a C string. */ 183 it's t, we are matching text in a C string.
184extern Lisp_Object re_match_object; 184
185 This is defined as a macro in thread.h, which see. */
186/* extern Lisp_Object re_match_object; */
185#endif 187#endif
186 188
187/* Roughly the maximum number of failure points on the stack. */ 189/* Roughly the maximum number of failure points on the stack. */
diff --git a/src/search.c b/src/search.c
index e597c33a0fb..9d2c8cb04fd 100644
--- a/src/search.c
+++ b/src/search.c
@@ -40,7 +40,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
40struct regexp_cache 40struct regexp_cache
41{ 41{
42 struct regexp_cache *next; 42 struct regexp_cache *next;
43 Lisp_Object regexp, whitespace_regexp; 43 Lisp_Object regexp, f_whitespace_regexp;
44 /* Syntax table for which the regexp applies. We need this because 44 /* Syntax table for which the regexp applies. We need this because
45 of character classes. If this is t, then the compiled pattern is valid 45 of character classes. If this is t, then the compiled pattern is valid
46 for any syntax-table. */ 46 for any syntax-table. */
@@ -75,12 +75,12 @@ static struct regexp_cache *searchbuf_head;
75 to call re_set_registers after compiling a new pattern or after 75 to call re_set_registers after compiling a new pattern or after
76 setting the match registers, so that the regex functions will be 76 setting the match registers, so that the regex functions will be
77 able to free or re-allocate it properly. */ 77 able to free or re-allocate it properly. */
78static struct re_registers search_regs; 78/* static struct re_registers search_regs; */
79 79
80/* The buffer in which the last search was performed, or 80/* The buffer in which the last search was performed, or
81 Qt if the last search was done in a string; 81 Qt if the last search was done in a string;
82 Qnil if no searching has been done yet. */ 82 Qnil if no searching has been done yet. */
83static Lisp_Object last_thing_searched; 83/* static Lisp_Object last_thing_searched; */
84 84
85static void set_search_regs (ptrdiff_t, ptrdiff_t); 85static void set_search_regs (ptrdiff_t, ptrdiff_t);
86static void save_search_regs (void); 86static void save_search_regs (void);
@@ -122,9 +122,9 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern,
122 cp->buf.multibyte = STRING_MULTIBYTE (pattern); 122 cp->buf.multibyte = STRING_MULTIBYTE (pattern);
123 cp->buf.charset_unibyte = charset_unibyte; 123 cp->buf.charset_unibyte = charset_unibyte;
124 if (STRINGP (Vsearch_spaces_regexp)) 124 if (STRINGP (Vsearch_spaces_regexp))
125 cp->whitespace_regexp = Vsearch_spaces_regexp; 125 cp->f_whitespace_regexp = Vsearch_spaces_regexp;
126 else 126 else
127 cp->whitespace_regexp = Qnil; 127 cp->f_whitespace_regexp = Qnil;
128 128
129 /* rms: I think BLOCK_INPUT is not needed here any more, 129 /* rms: I think BLOCK_INPUT is not needed here any more,
130 because regex.c defines malloc to call xmalloc. 130 because regex.c defines malloc to call xmalloc.
@@ -217,7 +217,7 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp,
217 && cp->posix == posix 217 && cp->posix == posix
218 && (EQ (cp->syntax_table, Qt) 218 && (EQ (cp->syntax_table, Qt)
219 || EQ (cp->syntax_table, BVAR (current_buffer, syntax_table))) 219 || EQ (cp->syntax_table, BVAR (current_buffer, syntax_table)))
220 && !NILP (Fequal (cp->whitespace_regexp, Vsearch_spaces_regexp)) 220 && !NILP (Fequal (cp->f_whitespace_regexp, Vsearch_spaces_regexp))
221 && cp->buf.charset_unibyte == charset_unibyte) 221 && cp->buf.charset_unibyte == charset_unibyte)
222 break; 222 break;
223 223
@@ -3089,9 +3089,9 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */)
3089 3089
3090/* If true the match data have been saved in saved_search_regs 3090/* If true the match data have been saved in saved_search_regs
3091 during the execution of a sentinel or filter. */ 3091 during the execution of a sentinel or filter. */
3092static bool search_regs_saved; 3092/* static bool search_regs_saved; */
3093static struct re_registers saved_search_regs; 3093/* static struct re_registers saved_search_regs; */
3094static Lisp_Object saved_last_thing_searched; 3094/* static Lisp_Object saved_last_thing_searched; */
3095 3095
3096/* Called from Flooking_at, Fstring_match, search_buffer, Fstore_match_data 3096/* Called from Flooking_at, Fstring_match, search_buffer, Fstore_match_data
3097 if asynchronous code (filter or sentinel) is running. */ 3097 if asynchronous code (filter or sentinel) is running. */
@@ -3401,10 +3401,10 @@ syms_of_search (void)
3401 searchbufs[i].buf.buffer = xmalloc (100); 3401 searchbufs[i].buf.buffer = xmalloc (100);
3402 searchbufs[i].buf.fastmap = searchbufs[i].fastmap; 3402 searchbufs[i].buf.fastmap = searchbufs[i].fastmap;
3403 searchbufs[i].regexp = Qnil; 3403 searchbufs[i].regexp = Qnil;
3404 searchbufs[i].whitespace_regexp = Qnil; 3404 searchbufs[i].f_whitespace_regexp = Qnil;
3405 searchbufs[i].syntax_table = Qnil; 3405 searchbufs[i].syntax_table = Qnil;
3406 staticpro (&searchbufs[i].regexp); 3406 staticpro (&searchbufs[i].regexp);
3407 staticpro (&searchbufs[i].whitespace_regexp); 3407 staticpro (&searchbufs[i].f_whitespace_regexp);
3408 staticpro (&searchbufs[i].syntax_table); 3408 staticpro (&searchbufs[i].syntax_table);
3409 searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]); 3409 searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]);
3410 } 3410 }
diff --git a/src/sysdep.c b/src/sysdep.c
index 257634292b1..3d2b9bdeeee 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -51,14 +51,19 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
51# include <math.h> 51# include <math.h>
52#endif 52#endif
53 53
54#ifdef HAVE_SOCKETS
55#include <sys/socket.h>
56#include <netdb.h>
57#endif /* HAVE_SOCKETS */
58
54#ifdef WINDOWSNT 59#ifdef WINDOWSNT
55#define read sys_read 60#define read sys_read
56#define write sys_write 61#define write sys_write
57#ifndef STDERR_FILENO 62#ifndef STDERR_FILENO
58#define STDERR_FILENO fileno(GetStdHandle(STD_ERROR_HANDLE)) 63#define STDERR_FILENO fileno(GetStdHandle(STD_ERROR_HANDLE))
59#endif 64#endif
60#include <windows.h> 65#include "w32.h"
61#endif /* not WINDOWSNT */ 66#endif /* WINDOWSNT */
62 67
63#include <sys/types.h> 68#include <sys/types.h>
64#include <sys/stat.h> 69#include <sys/stat.h>
diff --git a/src/systhread.c b/src/systhread.c
new file mode 100644
index 00000000000..c11e0247886
--- /dev/null
+++ b/src/systhread.c
@@ -0,0 +1,417 @@
1/* System thread definitions
2 Copyright (C) 2012, 2013 Free Software Foundation, Inc.
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software: you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation, either version 3 of the License, or
9(at your option) any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
18
19#include <config.h>
20#include <setjmp.h>
21#include "lisp.h"
22
23#ifndef THREADS_ENABLED
24
25void
26sys_mutex_init (sys_mutex_t *m)
27{
28 *m = 0;
29}
30
31void
32sys_mutex_lock (sys_mutex_t *m)
33{
34}
35
36void
37sys_mutex_unlock (sys_mutex_t *m)
38{
39}
40
41void
42sys_mutex_destroy (sys_mutex_t *m)
43{
44}
45
46void
47sys_cond_init (sys_cond_t *c)
48{
49 *c = 0;
50}
51
52void
53sys_cond_wait (sys_cond_t *c, sys_mutex_t *m)
54{
55}
56
57void
58sys_cond_signal (sys_cond_t *c)
59{
60}
61
62void
63sys_cond_broadcast (sys_cond_t *c)
64{
65}
66
67void
68sys_cond_destroy (sys_cond_t *c)
69{
70}
71
72sys_thread_t
73sys_thread_self (void)
74{
75 return 0;
76}
77
78int
79sys_thread_equal (sys_thread_t x, sys_thread_t y)
80{
81 return x == y;
82}
83
84int
85sys_thread_create (sys_thread_t *t, const char *name,
86 thread_creation_function *func, void *datum)
87{
88 return 0;
89}
90
91void
92sys_thread_yield (void)
93{
94}
95
96#elif defined (HAVE_PTHREAD)
97
98#include <sched.h>
99
100#ifdef HAVE_SYS_PRCTL_H
101#include <sys/prctl.h>
102#endif
103
104void
105sys_mutex_init (sys_mutex_t *mutex)
106{
107 pthread_mutex_init (mutex, NULL);
108}
109
110void
111sys_mutex_lock (sys_mutex_t *mutex)
112{
113 pthread_mutex_lock (mutex);
114}
115
116void
117sys_mutex_unlock (sys_mutex_t *mutex)
118{
119 pthread_mutex_unlock (mutex);
120}
121
122void
123sys_mutex_destroy (sys_mutex_t *mutex)
124{
125 pthread_mutex_destroy (mutex);
126}
127
128void
129sys_cond_init (sys_cond_t *cond)
130{
131 pthread_cond_init (cond, NULL);
132}
133
134void
135sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex)
136{
137 pthread_cond_wait (cond, mutex);
138}
139
140void
141sys_cond_signal (sys_cond_t *cond)
142{
143 pthread_cond_signal (cond);
144}
145
146void
147sys_cond_broadcast (sys_cond_t *cond)
148{
149 pthread_cond_broadcast (cond);
150}
151
152void
153sys_cond_destroy (sys_cond_t *cond)
154{
155 pthread_cond_destroy (cond);
156}
157
158sys_thread_t
159sys_thread_self (void)
160{
161 return pthread_self ();
162}
163
164int
165sys_thread_equal (sys_thread_t one, sys_thread_t two)
166{
167 return pthread_equal (one, two);
168}
169
170int
171sys_thread_create (sys_thread_t *thread_ptr, const char *name,
172 thread_creation_function *func, void *arg)
173{
174 pthread_attr_t attr;
175 int result = 0;
176
177 if (pthread_attr_init (&attr))
178 return 0;
179
180 if (!pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED))
181 {
182 result = pthread_create (thread_ptr, &attr, func, arg) == 0;
183#if defined (HAVE_SYS_PRCTL_H) && defined (HAVE_PRCTL) && defined (PR_SET_NAME)
184 if (result && name != NULL)
185 prctl (PR_SET_NAME, name);
186#endif
187 }
188
189 pthread_attr_destroy (&attr);
190
191 return result;
192}
193
194void
195sys_thread_yield (void)
196{
197 sched_yield ();
198}
199
200#elif defined (WINDOWSNT)
201
202#include <windows.h>
203
204/* Cannot include <process.h> because of the local header by the same
205 name, sigh. */
206uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *);
207
208/* Mutexes are implemented as critical sections, because they are
209 faster than Windows mutex objects (implemented in userspace), and
210 satisfy the requirements, since we only need to synchronize within a
211 single process. */
212void
213sys_mutex_init (sys_mutex_t *mutex)
214{
215 InitializeCriticalSection ((LPCRITICAL_SECTION)mutex);
216}
217
218void
219sys_mutex_lock (sys_mutex_t *mutex)
220{
221 /* FIXME: What happens if the owning thread exits without releasing
222 the mutex? Accoding to MSDN, the result is undefined behavior. */
223 EnterCriticalSection ((LPCRITICAL_SECTION)mutex);
224}
225
226void
227sys_mutex_unlock (sys_mutex_t *mutex)
228{
229 LeaveCriticalSection ((LPCRITICAL_SECTION)mutex);
230}
231
232void
233sys_mutex_destroy (sys_mutex_t *mutex)
234{
235 /* FIXME: According to MSDN, deleting a critical session that is
236 owned by a thread leaves the other threads waiting for the
237 critical session in an undefined state. Posix docs seem to say
238 the same about pthread_mutex_destroy. Do we need to protect
239 against such calamities? */
240 DeleteCriticalSection ((LPCRITICAL_SECTION)mutex);
241}
242
243void
244sys_cond_init (sys_cond_t *cond)
245{
246 cond->initialized = false;
247 cond->wait_count = 0;
248 /* Auto-reset event for signal. */
249 cond->events[CONDV_SIGNAL] = CreateEvent (NULL, FALSE, FALSE, NULL);
250 /* Manual-reset event for broadcast. */
251 cond->events[CONDV_BROADCAST] = CreateEvent (NULL, TRUE, FALSE, NULL);
252 if (!cond->events[CONDV_SIGNAL] || !cond->events[CONDV_BROADCAST])
253 return;
254 InitializeCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
255 cond->initialized = true;
256}
257
258void
259sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex)
260{
261 DWORD wait_result;
262 bool last_thread_waiting;
263
264 if (!cond->initialized)
265 return;
266
267 /* Increment the wait count avoiding race conditions. */
268 EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
269 cond->wait_count++;
270 LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
271
272 /* Release the mutex and wait for either the signal or the broadcast
273 event. */
274 LeaveCriticalSection ((LPCRITICAL_SECTION)mutex);
275 wait_result = WaitForMultipleObjects (2, cond->events, FALSE, INFINITE);
276
277 /* Decrement the wait count and see if we are the last thread
278 waiting on the condition variable. */
279 EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
280 cond->wait_count--;
281 last_thread_waiting =
282 wait_result == WAIT_OBJECT_0 + CONDV_BROADCAST
283 && cond->wait_count == 0;
284 LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
285
286 /* Broadcast uses a manual-reset event, so when the last thread is
287 released, we must manually reset that event. */
288 if (last_thread_waiting)
289 ResetEvent (cond->events[CONDV_BROADCAST]);
290
291 /* Per the API, re-acquire the mutex. */
292 EnterCriticalSection ((LPCRITICAL_SECTION)mutex);
293}
294
295void
296sys_cond_signal (sys_cond_t *cond)
297{
298 bool threads_waiting;
299
300 if (!cond->initialized)
301 return;
302
303 EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
304 threads_waiting = cond->wait_count > 0;
305 LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
306
307 if (threads_waiting)
308 SetEvent (cond->events[CONDV_SIGNAL]);
309}
310
311void
312sys_cond_broadcast (sys_cond_t *cond)
313{
314 bool threads_waiting;
315
316 if (!cond->initialized)
317 return;
318
319 EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
320 threads_waiting = cond->wait_count > 0;
321 LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
322
323 if (threads_waiting)
324 SetEvent (cond->events[CONDV_BROADCAST]);
325}
326
327void
328sys_cond_destroy (sys_cond_t *cond)
329{
330 if (cond->events[CONDV_SIGNAL])
331 CloseHandle (cond->events[CONDV_SIGNAL]);
332 if (cond->events[CONDV_BROADCAST])
333 CloseHandle (cond->events[CONDV_BROADCAST]);
334
335 if (!cond->initialized)
336 return;
337
338 /* FIXME: What if wait_count is non-zero, i.e. there are still
339 threads waiting on this condition variable? */
340 DeleteCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
341}
342
343sys_thread_t
344sys_thread_self (void)
345{
346 return (sys_thread_t) GetCurrentThreadId ();
347}
348
349int
350sys_thread_equal (sys_thread_t one, sys_thread_t two)
351{
352 return one == two;
353}
354
355static thread_creation_function *thread_start_address;
356
357/* _beginthread wants a void function, while we are passed a function
358 that returns a pointer. So we use a wrapper. */
359static void
360w32_beginthread_wrapper (void *arg)
361{
362 (void)thread_start_address (arg);
363}
364
365int
366sys_thread_create (sys_thread_t *thread_ptr, const char *name,
367 thread_creation_function *func, void *arg)
368{
369 /* FIXME: Do threads that run Lisp require some minimum amount of
370 stack? Zero here means each thread will get the same amount as
371 the main program. On GNU/Linux, it seems like the stack is 2MB
372 by default, overridden by RLIMIT_STACK at program start time.
373 Not sure what to do with this. See also the comment in
374 w32proc.c:new_child. */
375 const unsigned stack_size = 0;
376 uintptr_t thandle;
377
378 thread_start_address = func;
379
380 /* We use _beginthread rather than CreateThread because the former
381 arranges for the thread handle to be automatically closed when
382 the thread exits, thus preventing handle leaks and/or the need to
383 track all the threads and close their handles when they exit.
384 Also, MSDN seems to imply that code which uses CRT _must_ call
385 _beginthread, although if that is true, we already violate that
386 rule in many places... */
387 thandle = _beginthread (w32_beginthread_wrapper, stack_size, arg);
388 if (thandle == (uintptr_t)-1L)
389 return 0;
390
391 /* Kludge alert! We use the Windows thread ID, an unsigned 32-bit
392 number, as the sys_thread_t type, because that ID is the only
393 unique identifier of a thread on Windows. But _beginthread
394 returns a handle of the thread, and there's no easy way of
395 getting the thread ID given a handle (GetThreadId is available
396 only since Vista, so we cannot use it portably). Fortunately,
397 the value returned by sys_thread_create is not used by its
398 callers; instead, run_thread, which runs in the context of the
399 new thread, calls sys_thread_self and uses its return value;
400 sys_thread_self in this implementation calls GetCurrentThreadId.
401 Therefore, we return some more or less arbitrary value of the
402 thread ID from this function. */
403 *thread_ptr = thandle & 0xFFFFFFFF;
404 return 1;
405}
406
407void
408sys_thread_yield (void)
409{
410 Sleep (0);
411}
412
413#else
414
415#error port me
416
417#endif
diff --git a/src/systhread.h b/src/systhread.h
new file mode 100644
index 00000000000..b38fd8ffd45
--- /dev/null
+++ b/src/systhread.h
@@ -0,0 +1,112 @@
1/* System thread definitions
2 Copyright (C) 2012, 2013 Free Software Foundation, Inc.
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software: you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation, either version 3 of the License, or
9(at your option) any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
18
19#ifndef SYSTHREAD_H
20#define SYSTHREAD_H
21
22#ifdef THREADS_ENABLED
23
24#ifdef HAVE_PTHREAD
25
26#include <pthread.h>
27
28/* A system mutex is just a pthread mutex. This is only used for the
29 GIL. */
30typedef pthread_mutex_t sys_mutex_t;
31
32typedef pthread_cond_t sys_cond_t;
33
34/* A system thread. */
35typedef pthread_t sys_thread_t;
36
37#else /* HAVE_PTHREAD */
38
39#ifdef WINDOWSNT
40
41/* This header is indirectly included in every source file. We don't
42 want to include windows.h in every source file, so we repeat
43 declarations of the few necessary data types here (under different
44 names, to avoid conflicts with files that do include
45 windows.h). */
46
47typedef struct {
48 struct _CRITICAL_SECTION_DEBUG *DebugInfo;
49 long LockCount;
50 long RecursionCount;
51 void *OwningThread;
52 void *LockSemaphore;
53 unsigned long SpinCount;
54} w32thread_critsect;
55
56enum { CONDV_SIGNAL = 0, CONDV_BROADCAST = 1, CONDV_MAX = 2 };
57
58typedef struct {
59 /* Count of threads that are waiting for this condition variable. */
60 unsigned wait_count;
61 /* Critical section to protect changes to the count above. */
62 w32thread_critsect wait_count_lock;
63 /* Handles of events used for signal and broadcast. */
64 void *events[CONDV_MAX];
65 bool initialized;
66} w32thread_cond_t;
67
68typedef w32thread_critsect sys_mutex_t;
69
70typedef w32thread_cond_t sys_cond_t;
71
72typedef unsigned long sys_thread_t;
73
74#else /* !WINDOWSNT */
75
76#error port me
77
78#endif /* WINDOWSNT */
79#endif /* HAVE_PTHREAD */
80
81#else /* THREADS_ENABLED */
82
83/* For the no-threads case we can simply use dummy definitions. */
84typedef int sys_mutex_t;
85typedef int sys_cond_t;
86typedef int sys_thread_t;
87
88#endif /* THREADS_ENABLED */
89
90typedef void *(thread_creation_function) (void *);
91
92extern void sys_mutex_init (sys_mutex_t *);
93extern void sys_mutex_lock (sys_mutex_t *);
94extern void sys_mutex_unlock (sys_mutex_t *);
95extern void sys_mutex_destroy (sys_mutex_t *);
96
97extern void sys_cond_init (sys_cond_t *);
98extern void sys_cond_wait (sys_cond_t *, sys_mutex_t *);
99extern void sys_cond_signal (sys_cond_t *);
100extern void sys_cond_broadcast (sys_cond_t *);
101extern void sys_cond_destroy (sys_cond_t *);
102
103extern sys_thread_t sys_thread_self (void);
104extern int sys_thread_equal (sys_thread_t, sys_thread_t);
105
106extern int sys_thread_create (sys_thread_t *, const char *,
107 thread_creation_function *,
108 void *);
109
110extern void sys_thread_yield (void);
111
112#endif /* SYSTHREAD_H */
diff --git a/src/thread.c b/src/thread.c
new file mode 100644
index 00000000000..ae2ce3dc02b
--- /dev/null
+++ b/src/thread.c
@@ -0,0 +1,970 @@
1/* Threading code.
2 Copyright (C) 2012, 2013 Free Software Foundation, Inc.
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software: you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation, either version 3 of the License, or
9(at your option) any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
18
19
20#include <config.h>
21#include <setjmp.h>
22#include "lisp.h"
23#include "character.h"
24#include "buffer.h"
25#include "process.h"
26#include "coding.h"
27
28static struct thread_state primary_thread;
29
30struct thread_state *current_thread = &primary_thread;
31
32static struct thread_state *all_threads = &primary_thread;
33
34static sys_mutex_t global_lock;
35
36extern int poll_suppress_count;
37extern volatile int interrupt_input_blocked;
38
39
40
41/* m_specpdl is set when the thread is created and cleared when the
42 thread dies. */
43#define thread_alive_p(STATE) ((STATE)->m_specpdl != NULL)
44
45
46
47static void
48release_global_lock (void)
49{
50 sys_mutex_unlock (&global_lock);
51}
52
53/* You must call this after acquiring the global lock.
54 acquire_global_lock does it for you. */
55static void
56post_acquire_global_lock (struct thread_state *self)
57{
58 Lisp_Object buffer;
59 struct thread_state *prev_thread = current_thread;
60
61 /* Do this early on, so that code below could signal errors (e.g.,
62 unbind_for_thread_switch might) correctly, because we are already
63 running in the context of the thread pointed by SELF. */
64 current_thread = self;
65
66 if (prev_thread != current_thread)
67 {
68 /* PREV_THREAD is NULL if the previously current thread
69 exited. In this case, there is no reason to unbind, and
70 trying will crash. */
71 if (prev_thread != NULL)
72 unbind_for_thread_switch (prev_thread);
73 rebind_for_thread_switch ();
74 }
75
76 /* We need special handling to re-set the buffer. */
77 XSETBUFFER (buffer, self->m_current_buffer);
78 self->m_current_buffer = 0;
79 set_buffer_internal (XBUFFER (buffer));
80
81 if (!NILP (current_thread->error_symbol))
82 {
83 Lisp_Object sym = current_thread->error_symbol;
84 Lisp_Object data = current_thread->error_data;
85
86 current_thread->error_symbol = Qnil;
87 current_thread->error_data = Qnil;
88 Fsignal (sym, data);
89 }
90}
91
92static void
93acquire_global_lock (struct thread_state *self)
94{
95 sys_mutex_lock (&global_lock);
96 post_acquire_global_lock (self);
97}
98
99
100
101static void
102lisp_mutex_init (lisp_mutex_t *mutex)
103{
104 mutex->owner = NULL;
105 mutex->count = 0;
106 sys_cond_init (&mutex->condition);
107}
108
109static int
110lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
111{
112 struct thread_state *self;
113
114 if (mutex->owner == NULL)
115 {
116 mutex->owner = current_thread;
117 mutex->count = new_count == 0 ? 1 : new_count;
118 return 0;
119 }
120 if (mutex->owner == current_thread)
121 {
122 eassert (new_count == 0);
123 ++mutex->count;
124 return 0;
125 }
126
127 self = current_thread;
128 self->wait_condvar = &mutex->condition;
129 while (mutex->owner != NULL && (new_count != 0
130 || NILP (self->error_symbol)))
131 sys_cond_wait (&mutex->condition, &global_lock);
132 self->wait_condvar = NULL;
133
134 if (new_count == 0 && !NILP (self->error_symbol))
135 return 1;
136
137 mutex->owner = self;
138 mutex->count = new_count == 0 ? 1 : new_count;
139
140 return 1;
141}
142
143static int
144lisp_mutex_unlock (lisp_mutex_t *mutex)
145{
146 if (mutex->owner != current_thread)
147 error ("Cannot unlock mutex owned by another thread");
148
149 if (--mutex->count > 0)
150 return 0;
151
152 mutex->owner = NULL;
153 sys_cond_broadcast (&mutex->condition);
154
155 return 1;
156}
157
158static unsigned int
159lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex)
160{
161 unsigned int result = mutex->count;
162
163 /* Ensured by condvar code. */
164 eassert (mutex->owner == current_thread);
165
166 mutex->count = 0;
167 mutex->owner = NULL;
168 sys_cond_broadcast (&mutex->condition);
169
170 return result;
171}
172
173static void
174lisp_mutex_destroy (lisp_mutex_t *mutex)
175{
176 sys_cond_destroy (&mutex->condition);
177}
178
179static int
180lisp_mutex_owned_p (lisp_mutex_t *mutex)
181{
182 return mutex->owner == current_thread;
183}
184
185
186
187DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
188 doc: /* Create a mutex.
189A mutex provides a synchronization point for threads.
190Only one thread at a time can hold a mutex. Other threads attempting
191to acquire it will block until the mutex is available.
192
193A thread can acquire a mutex any number of times.
194
195NAME, if given, is used as the name of the mutex. The name is
196informational only. */)
197 (Lisp_Object name)
198{
199 struct Lisp_Mutex *mutex;
200 Lisp_Object result;
201
202 if (!NILP (name))
203 CHECK_STRING (name);
204
205 mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
206 memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
207 0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
208 mutex));
209 mutex->name = name;
210 lisp_mutex_init (&mutex->mutex);
211
212 XSETMUTEX (result, mutex);
213 return result;
214}
215
216static void
217mutex_lock_callback (void *arg)
218{
219 struct Lisp_Mutex *mutex = arg;
220 struct thread_state *self = current_thread;
221
222 if (lisp_mutex_lock (&mutex->mutex, 0))
223 post_acquire_global_lock (self);
224}
225
226static void
227do_unwind_mutex_lock (void)
228{
229 current_thread->event_object = Qnil;
230}
231
232DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
233 doc: /* Acquire a mutex.
234If the current thread already owns MUTEX, increment the count and
235return.
236Otherwise, if no thread owns MUTEX, make the current thread own it.
237Otherwise, block until MUTEX is available, or until the current thread
238is signalled using `thread-signal'.
239Note that calls to `mutex-lock' and `mutex-unlock' must be paired. */)
240 (Lisp_Object mutex)
241{
242 struct Lisp_Mutex *lmutex;
243 ptrdiff_t count = SPECPDL_INDEX ();
244
245 CHECK_MUTEX (mutex);
246 lmutex = XMUTEX (mutex);
247
248 current_thread->event_object = mutex;
249 record_unwind_protect_void (do_unwind_mutex_lock);
250 flush_stack_call_func (mutex_lock_callback, lmutex);
251 return unbind_to (count, Qnil);
252}
253
254static void
255mutex_unlock_callback (void *arg)
256{
257 struct Lisp_Mutex *mutex = arg;
258 struct thread_state *self = current_thread;
259
260 if (lisp_mutex_unlock (&mutex->mutex))
261 post_acquire_global_lock (self);
262}
263
264DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
265 doc: /* Release the mutex.
266If this thread does not own MUTEX, signal an error.
267Otherwise, decrement the mutex's count. If the count is zero,
268release MUTEX. */)
269 (Lisp_Object mutex)
270{
271 struct Lisp_Mutex *lmutex;
272
273 CHECK_MUTEX (mutex);
274 lmutex = XMUTEX (mutex);
275
276 flush_stack_call_func (mutex_unlock_callback, lmutex);
277 return Qnil;
278}
279
280DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0,
281 doc: /* Return the name of MUTEX.
282If no name was given when MUTEX was created, return nil. */)
283 (Lisp_Object mutex)
284{
285 struct Lisp_Mutex *lmutex;
286
287 CHECK_MUTEX (mutex);
288 lmutex = XMUTEX (mutex);
289
290 return lmutex->name;
291}
292
293void
294finalize_one_mutex (struct Lisp_Mutex *mutex)
295{
296 lisp_mutex_destroy (&mutex->mutex);
297}
298
299
300
301DEFUN ("make-condition-variable",
302 Fmake_condition_variable, Smake_condition_variable,
303 1, 2, 0,
304 doc: /* Make a condition variable associated with MUTEX.
305A condition variable provides a way for a thread to sleep while
306waiting for a state change.
307
308MUTEX is the mutex associated with this condition variable.
309NAME, if given, is the name of this condition variable. The name is
310informational only. */)
311 (Lisp_Object mutex, Lisp_Object name)
312{
313 struct Lisp_CondVar *condvar;
314 Lisp_Object result;
315
316 CHECK_MUTEX (mutex);
317 if (!NILP (name))
318 CHECK_STRING (name);
319
320 condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
321 memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
322 0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
323 cond));
324 condvar->mutex = mutex;
325 condvar->name = name;
326 sys_cond_init (&condvar->cond);
327
328 XSETCONDVAR (result, condvar);
329 return result;
330}
331
332static void
333condition_wait_callback (void *arg)
334{
335 struct Lisp_CondVar *cvar = arg;
336 struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex);
337 struct thread_state *self = current_thread;
338 unsigned int saved_count;
339 Lisp_Object cond;
340
341 XSETCONDVAR (cond, cvar);
342 self->event_object = cond;
343 saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
344 /* If we were signalled while unlocking, we skip the wait, but we
345 still must reacquire our lock. */
346 if (NILP (self->error_symbol))
347 {
348 self->wait_condvar = &cvar->cond;
349 sys_cond_wait (&cvar->cond, &global_lock);
350 self->wait_condvar = NULL;
351 }
352 lisp_mutex_lock (&mutex->mutex, saved_count);
353 self->event_object = Qnil;
354 post_acquire_global_lock (self);
355}
356
357DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
358 doc: /* Wait for the condition variable COND to be notified.
359COND is the condition variable to wait on.
360
361The mutex associated with COND must be held when this is called.
362It is an error if it is not held.
363
364This releases the mutex and waits for COND to be notified or for
365this thread to be signalled with `thread-signal'. When
366`condition-wait' returns, COND's mutex will again be locked by
367this thread. */)
368 (Lisp_Object cond)
369{
370 struct Lisp_CondVar *cvar;
371 struct Lisp_Mutex *mutex;
372
373 CHECK_CONDVAR (cond);
374 cvar = XCONDVAR (cond);
375
376 mutex = XMUTEX (cvar->mutex);
377 if (!lisp_mutex_owned_p (&mutex->mutex))
378 error ("Condition variable's mutex is not held by current thread");
379
380 flush_stack_call_func (condition_wait_callback, cvar);
381
382 return Qnil;
383}
384
385/* Used to communicate argumnets to condition_notify_callback. */
386struct notify_args
387{
388 struct Lisp_CondVar *cvar;
389 int all;
390};
391
392static void
393condition_notify_callback (void *arg)
394{
395 struct notify_args *na = arg;
396 struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex);
397 struct thread_state *self = current_thread;
398 unsigned int saved_count;
399 Lisp_Object cond;
400
401 XSETCONDVAR (cond, na->cvar);
402 saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
403 if (na->all)
404 sys_cond_broadcast (&na->cvar->cond);
405 else
406 sys_cond_signal (&na->cvar->cond);
407 lisp_mutex_lock (&mutex->mutex, saved_count);
408 post_acquire_global_lock (self);
409}
410
411DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0,
412 doc: /* Notify COND, a condition variable.
413This wakes a thread waiting on COND.
414If ALL is non-nil, all waiting threads are awoken.
415
416The mutex associated with COND must be held when this is called.
417It is an error if it is not held.
418
419This releases COND's mutex when notifying COND. When
420`condition-notify' returns, the mutex will again be locked by this
421thread. */)
422 (Lisp_Object cond, Lisp_Object all)
423{
424 struct Lisp_CondVar *cvar;
425 struct Lisp_Mutex *mutex;
426 struct notify_args args;
427
428 CHECK_CONDVAR (cond);
429 cvar = XCONDVAR (cond);
430
431 mutex = XMUTEX (cvar->mutex);
432 if (!lisp_mutex_owned_p (&mutex->mutex))
433 error ("Condition variable's mutex is not held by current thread");
434
435 args.cvar = cvar;
436 args.all = !NILP (all);
437 flush_stack_call_func (condition_notify_callback, &args);
438
439 return Qnil;
440}
441
442DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0,
443 doc: /* Return the mutex associated with condition variable COND. */)
444 (Lisp_Object cond)
445{
446 struct Lisp_CondVar *cvar;
447
448 CHECK_CONDVAR (cond);
449 cvar = XCONDVAR (cond);
450
451 return cvar->mutex;
452}
453
454DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0,
455 doc: /* Return the name of condition variable COND.
456If no name was given when COND was created, return nil. */)
457 (Lisp_Object cond)
458{
459 struct Lisp_CondVar *cvar;
460
461 CHECK_CONDVAR (cond);
462 cvar = XCONDVAR (cond);
463
464 return cvar->name;
465}
466
467void
468finalize_one_condvar (struct Lisp_CondVar *condvar)
469{
470 sys_cond_destroy (&condvar->cond);
471}
472
473
474
475struct select_args
476{
477 select_func *func;
478 int max_fds;
479 fd_set *rfds;
480 fd_set *wfds;
481 fd_set *efds;
482 struct timespec *timeout;
483 sigset_t *sigmask;
484 int result;
485};
486
487static void
488really_call_select (void *arg)
489{
490 struct select_args *sa = arg;
491 struct thread_state *self = current_thread;
492
493 release_global_lock ();
494 sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
495 sa->timeout, sa->sigmask);
496 acquire_global_lock (self);
497}
498
499int
500thread_select (select_func *func, int max_fds, fd_set *rfds,
501 fd_set *wfds, fd_set *efds, struct timespec *timeout,
502 sigset_t *sigmask)
503{
504 struct select_args sa;
505
506 sa.func = func;
507 sa.max_fds = max_fds;
508 sa.rfds = rfds;
509 sa.wfds = wfds;
510 sa.efds = efds;
511 sa.timeout = timeout;
512 sa.sigmask = sigmask;
513 flush_stack_call_func (really_call_select, &sa);
514 return sa.result;
515}
516
517
518
519static void
520mark_one_thread (struct thread_state *thread)
521{
522 struct handler *handler;
523 Lisp_Object tem;
524
525 mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
526
527 mark_stack (thread->m_stack_bottom, thread->stack_top);
528
529 for (handler = thread->m_handlerlist; handler; handler = handler->next)
530 {
531 mark_object (handler->tag_or_ch);
532 mark_object (handler->val);
533 }
534
535 if (thread->m_current_buffer)
536 {
537 XSETBUFFER (tem, thread->m_current_buffer);
538 mark_object (tem);
539 }
540
541 mark_object (thread->m_last_thing_searched);
542
543 if (!NILP (thread->m_saved_last_thing_searched))
544 mark_object (thread->m_saved_last_thing_searched);
545}
546
547static void
548mark_threads_callback (void *ignore)
549{
550 struct thread_state *iter;
551
552 for (iter = all_threads; iter; iter = iter->next_thread)
553 {
554 Lisp_Object thread_obj;
555
556 XSETTHREAD (thread_obj, iter);
557 mark_object (thread_obj);
558 mark_one_thread (iter);
559 }
560}
561
562void
563mark_threads (void)
564{
565 flush_stack_call_func (mark_threads_callback, NULL);
566}
567
568void
569unmark_threads (void)
570{
571 struct thread_state *iter;
572
573 for (iter = all_threads; iter; iter = iter->next_thread)
574 if (iter->m_byte_stack_list)
575 relocate_byte_stack (iter->m_byte_stack_list);
576}
577
578
579
580static void
581yield_callback (void *ignore)
582{
583 struct thread_state *self = current_thread;
584
585 release_global_lock ();
586 sys_thread_yield ();
587 acquire_global_lock (self);
588}
589
590DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
591 doc: /* Yield the CPU to another thread. */)
592 (void)
593{
594 flush_stack_call_func (yield_callback, NULL);
595 return Qnil;
596}
597
598static Lisp_Object
599invoke_thread_function (void)
600{
601 int count = SPECPDL_INDEX ();
602
603 Ffuncall (1, &current_thread->function);
604 return unbind_to (count, Qnil);
605}
606
607static Lisp_Object
608do_nothing (Lisp_Object whatever)
609{
610 return whatever;
611}
612
613static void *
614run_thread (void *state)
615{
616 char stack_pos;
617 struct thread_state *self = state;
618 struct thread_state **iter;
619
620 self->m_stack_bottom = &stack_pos;
621 self->stack_top = &stack_pos;
622 self->thread_id = sys_thread_self ();
623
624 acquire_global_lock (self);
625
626 { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
627 This is important since handlerlist->nextfree holds the freelist
628 which would otherwise leak every time we unwind back to top-level. */
629 handlerlist_sentinel = xzalloc (sizeof (struct handler));
630 handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
631 struct handler *c = push_handler (Qunbound, CATCHER);
632 eassert (c == handlerlist_sentinel);
633 handlerlist_sentinel->nextfree = NULL;
634 handlerlist_sentinel->next = NULL;
635 }
636
637 /* It might be nice to do something with errors here. */
638 internal_condition_case (invoke_thread_function, Qt, do_nothing);
639
640 update_processes_for_thread_death (Fcurrent_thread ());
641
642 xfree (self->m_specpdl - 1);
643 self->m_specpdl = NULL;
644 self->m_specpdl_ptr = NULL;
645 self->m_specpdl_size = 0;
646
647 {
648 struct handler *c, *c_next;
649 for (c = handlerlist_sentinel; c; c = c_next)
650 {
651 c_next = c->nextfree;
652 xfree (c);
653 }
654 }
655
656 current_thread = NULL;
657 sys_cond_broadcast (&self->thread_condvar);
658
659 /* Unlink this thread from the list of all threads. Note that we
660 have to do this very late, after broadcasting our death.
661 Otherwise the GC may decide to reap the thread_state object,
662 leading to crashes. */
663 for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
664 ;
665 *iter = (*iter)->next_thread;
666
667 release_global_lock ();
668
669 return NULL;
670}
671
672void
673finalize_one_thread (struct thread_state *state)
674{
675 sys_cond_destroy (&state->thread_condvar);
676}
677
678DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
679 doc: /* Start a new thread and run FUNCTION in it.
680When the function exits, the thread dies.
681If NAME is given, it must be a string; it names the new thread. */)
682 (Lisp_Object function, Lisp_Object name)
683{
684 sys_thread_t thr;
685 struct thread_state *new_thread;
686 Lisp_Object result;
687 const char *c_name = NULL;
688 size_t offset = offsetof (struct thread_state, m_byte_stack_list);
689
690 /* Can't start a thread in temacs. */
691 if (!initialized)
692 emacs_abort ();
693
694 if (!NILP (name))
695 CHECK_STRING (name);
696
697 new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_byte_stack_list,
698 PVEC_THREAD);
699 memset ((char *) new_thread + offset, 0,
700 sizeof (struct thread_state) - offset);
701
702 new_thread->function = function;
703 new_thread->name = name;
704 new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
705 new_thread->m_saved_last_thing_searched = Qnil;
706 new_thread->m_current_buffer = current_thread->m_current_buffer;
707 new_thread->error_symbol = Qnil;
708 new_thread->error_data = Qnil;
709 new_thread->event_object = Qnil;
710
711 new_thread->m_specpdl_size = 50;
712 new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
713 * sizeof (union specbinding));
714 /* Skip the dummy entry. */
715 ++new_thread->m_specpdl;
716 new_thread->m_specpdl_ptr = new_thread->m_specpdl;
717
718 sys_cond_init (&new_thread->thread_condvar);
719
720 /* We'll need locking here eventually. */
721 new_thread->next_thread = all_threads;
722 all_threads = new_thread;
723
724 if (!NILP (name))
725 c_name = SSDATA (ENCODE_UTF_8 (name));
726
727 if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
728 {
729 /* Restore the previous situation. */
730 all_threads = all_threads->next_thread;
731 error ("Could not start a new thread");
732 }
733
734 /* FIXME: race here where new thread might not be filled in? */
735 XSETTHREAD (result, new_thread);
736 return result;
737}
738
739DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
740 doc: /* Return the current thread. */)
741 (void)
742{
743 Lisp_Object result;
744 XSETTHREAD (result, current_thread);
745 return result;
746}
747
748DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
749 doc: /* Return the name of the THREAD.
750The name is the same object that was passed to `make-thread'. */)
751 (Lisp_Object thread)
752{
753 struct thread_state *tstate;
754
755 CHECK_THREAD (thread);
756 tstate = XTHREAD (thread);
757
758 return tstate->name;
759}
760
761static void
762thread_signal_callback (void *arg)
763{
764 struct thread_state *tstate = arg;
765 struct thread_state *self = current_thread;
766
767 sys_cond_broadcast (tstate->wait_condvar);
768 post_acquire_global_lock (self);
769}
770
771DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
772 doc: /* Signal an error in a thread.
773This acts like `signal', but arranges for the signal to be raised
774in THREAD. If THREAD is the current thread, acts just like `signal'.
775This will interrupt a blocked call to `mutex-lock', `condition-wait',
776or `thread-join' in the target thread. */)
777 (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
778{
779 struct thread_state *tstate;
780
781 CHECK_THREAD (thread);
782 tstate = XTHREAD (thread);
783
784 if (tstate == current_thread)
785 Fsignal (error_symbol, data);
786
787 /* What to do if thread is already signalled? */
788 /* What if error_symbol is Qnil? */
789 tstate->error_symbol = error_symbol;
790 tstate->error_data = data;
791
792 if (tstate->wait_condvar)
793 flush_stack_call_func (thread_signal_callback, tstate);
794
795 return Qnil;
796}
797
798DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
799 doc: /* Return t if THREAD is alive, or nil if it has exited. */)
800 (Lisp_Object thread)
801{
802 struct thread_state *tstate;
803
804 CHECK_THREAD (thread);
805 tstate = XTHREAD (thread);
806
807 return thread_alive_p (tstate) ? Qt : Qnil;
808}
809
810DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
811 doc: /* Return the object that THREAD is blocking on.
812If THREAD is blocked in `thread-join' on a second thread, return that
813thread.
814If THREAD is blocked in `mutex-lock', return the mutex.
815If THREAD is blocked in `condition-wait', return the condition variable.
816Otherwise, if THREAD is not blocked, return nil. */)
817 (Lisp_Object thread)
818{
819 struct thread_state *tstate;
820
821 CHECK_THREAD (thread);
822 tstate = XTHREAD (thread);
823
824 return tstate->event_object;
825}
826
827static void
828thread_join_callback (void *arg)
829{
830 struct thread_state *tstate = arg;
831 struct thread_state *self = current_thread;
832 Lisp_Object thread;
833
834 XSETTHREAD (thread, tstate);
835 self->event_object = thread;
836 self->wait_condvar = &tstate->thread_condvar;
837 while (thread_alive_p (tstate) && NILP (self->error_symbol))
838 sys_cond_wait (self->wait_condvar, &global_lock);
839
840 self->wait_condvar = NULL;
841 self->event_object = Qnil;
842 post_acquire_global_lock (self);
843}
844
845DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
846 doc: /* Wait for THREAD to exit.
847This blocks the current thread until THREAD exits or until
848the current thread is signaled.
849It is an error for a thread to try to join itself. */)
850 (Lisp_Object thread)
851{
852 struct thread_state *tstate;
853
854 CHECK_THREAD (thread);
855 tstate = XTHREAD (thread);
856
857 if (tstate == current_thread)
858 error ("Cannot join current thread");
859
860 if (thread_alive_p (tstate))
861 flush_stack_call_func (thread_join_callback, tstate);
862
863 return Qnil;
864}
865
866DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
867 doc: /* Return a list of all the live threads. */)
868 (void)
869{
870 Lisp_Object result = Qnil;
871 struct thread_state *iter;
872
873 for (iter = all_threads; iter; iter = iter->next_thread)
874 {
875 if (thread_alive_p (iter))
876 {
877 Lisp_Object thread;
878
879 XSETTHREAD (thread, iter);
880 result = Fcons (thread, result);
881 }
882 }
883
884 return result;
885}
886
887
888
889bool
890thread_check_current_buffer (struct buffer *buffer)
891{
892 struct thread_state *iter;
893
894 for (iter = all_threads; iter; iter = iter->next_thread)
895 {
896 if (iter == current_thread)
897 continue;
898
899 if (iter->m_current_buffer == buffer)
900 return true;
901 }
902
903 return false;
904}
905
906
907
908static void
909init_primary_thread (void)
910{
911 primary_thread.header.size
912 = PSEUDOVECSIZE (struct thread_state, m_byte_stack_list);
913 XSETPVECTYPE (&primary_thread, PVEC_THREAD);
914 primary_thread.m_last_thing_searched = Qnil;
915 primary_thread.m_saved_last_thing_searched = Qnil;
916 primary_thread.name = Qnil;
917 primary_thread.function = Qnil;
918 primary_thread.error_symbol = Qnil;
919 primary_thread.error_data = Qnil;
920 primary_thread.event_object = Qnil;
921}
922
923void
924init_threads_once (void)
925{
926 init_primary_thread ();
927}
928
929void
930init_threads (void)
931{
932 init_primary_thread ();
933 sys_cond_init (&primary_thread.thread_condvar);
934 sys_mutex_init (&global_lock);
935 sys_mutex_lock (&global_lock);
936 current_thread = &primary_thread;
937 primary_thread.thread_id = sys_thread_self ();
938}
939
940void
941syms_of_threads (void)
942{
943#ifndef THREADS_ENABLED
944 if (0)
945#endif
946 {
947 defsubr (&Sthread_yield);
948 defsubr (&Smake_thread);
949 defsubr (&Scurrent_thread);
950 defsubr (&Sthread_name);
951 defsubr (&Sthread_signal);
952 defsubr (&Sthread_alive_p);
953 defsubr (&Sthread_join);
954 defsubr (&Sthread_blocker);
955 defsubr (&Sall_threads);
956 defsubr (&Smake_mutex);
957 defsubr (&Smutex_lock);
958 defsubr (&Smutex_unlock);
959 defsubr (&Smutex_name);
960 defsubr (&Smake_condition_variable);
961 defsubr (&Scondition_wait);
962 defsubr (&Scondition_notify);
963 defsubr (&Scondition_mutex);
964 defsubr (&Scondition_name);
965 }
966
967 DEFSYM (Qthreadp, "threadp");
968 DEFSYM (Qmutexp, "mutexp");
969 DEFSYM (Qcondition_variable_p, "condition-variable-p");
970}
diff --git a/src/thread.h b/src/thread.h
new file mode 100644
index 00000000000..a9de754d6b4
--- /dev/null
+++ b/src/thread.h
@@ -0,0 +1,237 @@
1/* Thread definitions
2 Copyright (C) 2012, 2013 Free Software Foundation, Inc.
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software: you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation, either version 3 of the License, or
9(at your option) any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
18
19#ifndef THREAD_H
20#define THREAD_H
21
22#include <sys/types.h> /* for ssize_t used by regex.h */
23#include "regex.h"
24
25#ifdef WINDOWSNT
26#include <sys/socket.h>
27#endif
28
29#include "sysselect.h" /* FIXME */
30#include "systime.h" /* FIXME */
31
32struct thread_state
33{
34 struct vectorlike_header header;
35
36 /* The buffer in which the last search was performed, or
37 Qt if the last search was done in a string;
38 Qnil if no searching has been done yet. */
39 Lisp_Object m_last_thing_searched;
40#define last_thing_searched (current_thread->m_last_thing_searched)
41
42 Lisp_Object m_saved_last_thing_searched;
43#define saved_last_thing_searched (current_thread->m_saved_last_thing_searched)
44
45 /* The thread's name. */
46 Lisp_Object name;
47
48 /* The thread's function. */
49 Lisp_Object function;
50
51 /* If non-nil, this thread has been signalled. */
52 Lisp_Object error_symbol;
53 Lisp_Object error_data;
54
55 /* If we are waiting for some event, this holds the object we are
56 waiting on. */
57 Lisp_Object event_object;
58
59 /* m_byte_stack_list must be the first non-lisp field. */
60 /* A list of currently active byte-code execution value stacks.
61 Fbyte_code adds an entry to the head of this list before it starts
62 processing byte-code, and it removed the entry again when it is
63 done. Signalling an error truncates the list. */
64 struct byte_stack *m_byte_stack_list;
65#define byte_stack_list (current_thread->m_byte_stack_list)
66
67 /* An address near the bottom of the stack.
68 Tells GC how to save a copy of the stack. */
69 char *m_stack_bottom;
70#define stack_bottom (current_thread->m_stack_bottom)
71
72 /* An address near the top of the stack. */
73 char *stack_top;
74
75 struct catchtag *m_catchlist;
76#define catchlist (current_thread->m_catchlist)
77
78 /* Chain of condition handlers currently in effect.
79 The elements of this chain are contained in the stack frames
80 of Fcondition_case and internal_condition_case.
81 When an error is signaled (by calling Fsignal, below),
82 this chain is searched for an element that applies. */
83 struct handler *m_handlerlist;
84#define handlerlist (current_thread->m_handlerlist)
85
86 struct handler *m_handlerlist_sentinel;
87#define handlerlist_sentinel (current_thread->m_handlerlist_sentinel)
88
89 /* Current number of specbindings allocated in specpdl. */
90 ptrdiff_t m_specpdl_size;
91#define specpdl_size (current_thread->m_specpdl_size)
92
93 /* Pointer to beginning of specpdl. */
94 union specbinding *m_specpdl;
95#define specpdl (current_thread->m_specpdl)
96
97 /* Pointer to first unused element in specpdl. */
98 union specbinding *m_specpdl_ptr;
99#define specpdl_ptr (current_thread->m_specpdl_ptr)
100
101 /* Depth in Lisp evaluations and function calls. */
102 EMACS_INT m_lisp_eval_depth;
103#define lisp_eval_depth (current_thread->m_lisp_eval_depth)
104
105 /* This points to the current buffer. */
106 struct buffer *m_current_buffer;
107#define current_buffer (current_thread->m_current_buffer)
108
109 /* Every call to re_match, etc., must pass &search_regs as the regs
110 argument unless you can show it is unnecessary (i.e., if re_match
111 is certainly going to be called again before region-around-match
112 can be called).
113
114 Since the registers are now dynamically allocated, we need to make
115 sure not to refer to the Nth register before checking that it has
116 been allocated by checking search_regs.num_regs.
117
118 The regex code keeps track of whether it has allocated the search
119 buffer using bits in the re_pattern_buffer. This means that whenever
120 you compile a new pattern, it completely forgets whether it has
121 allocated any registers, and will allocate new registers the next
122 time you call a searching or matching function. Therefore, we need
123 to call re_set_registers after compiling a new pattern or after
124 setting the match registers, so that the regex functions will be
125 able to free or re-allocate it properly. */
126 struct re_registers m_search_regs;
127#define search_regs (current_thread->m_search_regs)
128
129 /* If non-zero the match data have been saved in saved_search_regs
130 during the execution of a sentinel or filter. */
131 bool m_search_regs_saved;
132#define search_regs_saved (current_thread->m_search_regs_saved)
133
134 struct re_registers m_saved_search_regs;
135#define saved_search_regs (current_thread->m_saved_search_regs)
136
137 /* This is the string or buffer in which we
138 are matching. It is used for looking up syntax properties.
139
140 If the value is a Lisp string object, we are matching text in that
141 string; if it's nil, we are matching text in the current buffer; if
142 it's t, we are matching text in a C string. */
143 Lisp_Object m_re_match_object;
144#define re_match_object (current_thread->m_re_match_object)
145
146 /* This variable is different from waiting_for_input in keyboard.c.
147 It is used to communicate to a lisp process-filter/sentinel (via the
148 function Fwaiting_for_user_input_p) whether Emacs was waiting
149 for user-input when that process-filter was called.
150 waiting_for_input cannot be used as that is by definition 0 when
151 lisp code is being evalled.
152 This is also used in record_asynch_buffer_change.
153 For that purpose, this must be 0
154 when not inside wait_reading_process_output. */
155 int m_waiting_for_user_input_p;
156#define waiting_for_user_input_p (current_thread->m_waiting_for_user_input_p)
157
158 /* The OS identifier for this thread. */
159 sys_thread_t thread_id;
160
161 /* The condition variable for this thread. This is associated with
162 the global lock. This thread broadcasts to it when it exits. */
163 sys_cond_t thread_condvar;
164
165 /* This thread might be waiting for some condition. If so, this
166 points to the condition. If the thread is interrupted, the
167 interrupter should broadcast to this condition. */
168 sys_cond_t *wait_condvar;
169
170 /* Threads are kept on a linked list. */
171 struct thread_state *next_thread;
172};
173
174/* A mutex in lisp is represented by a system condition variable.
175 The system mutex associated with this condition variable is the
176 global lock.
177
178 Using a condition variable lets us implement interruptibility for
179 lisp mutexes. */
180typedef struct
181{
182 /* The owning thread, or NULL if unlocked. */
183 struct thread_state *owner;
184 /* The lock count. */
185 unsigned int count;
186 /* The underlying system condition variable. */
187 sys_cond_t condition;
188} lisp_mutex_t;
189
190/* A mutex as a lisp object. */
191struct Lisp_Mutex
192{
193 struct vectorlike_header header;
194
195 /* The name of the mutex, or nil. */
196 Lisp_Object name;
197
198 /* The lower-level mutex object. */
199 lisp_mutex_t mutex;
200};
201
202/* A condition variable as a lisp object. */
203struct Lisp_CondVar
204{
205 struct vectorlike_header header;
206
207 /* The associated mutex. */
208 Lisp_Object mutex;
209
210 /* The name of the condition variable, or nil. */
211 Lisp_Object name;
212
213 /* The lower-level condition variable object. */
214 sys_cond_t cond;
215};
216
217extern struct thread_state *current_thread;
218
219extern void unmark_threads (void);
220extern void finalize_one_thread (struct thread_state *state);
221extern void finalize_one_mutex (struct Lisp_Mutex *);
222extern void finalize_one_condvar (struct Lisp_CondVar *);
223
224extern void init_threads_once (void);
225extern void init_threads (void);
226extern void syms_of_threads (void);
227
228typedef int select_func (int, fd_set *, fd_set *, fd_set *,
229 const struct timespec *, const sigset_t *);
230
231int thread_select (select_func *func, int max_fds, fd_set *rfds,
232 fd_set *wfds, fd_set *efds, struct timespec *timeout,
233 sigset_t *sigmask);
234
235bool thread_check_current_buffer (struct buffer *);
236
237#endif /* THREAD_H */
diff --git a/src/w32.c b/src/w32.c
index fa7fec700c6..e96f29791ea 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -272,7 +272,7 @@ static BOOL WINAPI revert_to_self (void);
272static int sys_access (const char *, int); 272static int sys_access (const char *, int);
273extern void *e_malloc (size_t); 273extern void *e_malloc (size_t);
274extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, 274extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *,
275 struct timespec *, void *); 275 const struct timespec *, const sigset_t *);
276extern int sys_dup (int); 276extern int sys_dup (int);
277 277
278 278
diff --git a/src/w32proc.c b/src/w32proc.c
index 189034c4e2d..6f3a6e0efca 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -72,7 +72,7 @@ extern BOOL g_b_init_compare_string_w;
72extern BOOL g_b_init_debug_break_process; 72extern BOOL g_b_init_debug_break_process;
73 73
74int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, 74int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *,
75 struct timespec *, void *); 75 const struct timespec *, const sigset_t *);
76 76
77/* Signal handlers...SIG_DFL == 0 so this is initialized correctly. */ 77/* Signal handlers...SIG_DFL == 0 so this is initialized correctly. */
78static signal_handler sig_handlers[NSIG]; 78static signal_handler sig_handlers[NSIG];
@@ -849,8 +849,8 @@ alarm (int seconds)
849 stream is terminated, terminates the reader thread as part of 849 stream is terminated, terminates the reader thread as part of
850 deleting the child_process object. 850 deleting the child_process object.
851 851
852 The sys_select function emulates the Posix 'pselect' function; it 852 The sys_select function emulates the Posix 'pselect' functionality;
853 is needed because the Windows 'select' function supports only 853 it is needed because the Windows 'select' function supports only
854 network sockets, while Emacs expects 'pselect' to work for any file 854 network sockets, while Emacs expects 'pselect' to work for any file
855 descriptor, including pipes and serial streams. 855 descriptor, including pipes and serial streams.
856 856
@@ -2096,7 +2096,7 @@ extern int proc_buffered_char[];
2096 2096
2097int 2097int
2098sys_select (int nfds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, 2098sys_select (int nfds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds,
2099 struct timespec *timeout, void *ignored) 2099 const struct timespec *timeout, const sigset_t *ignored)
2100{ 2100{
2101 SELECT_TYPE orfds, owfds; 2101 SELECT_TYPE orfds, owfds;
2102 DWORD timeout_ms, start_time; 2102 DWORD timeout_ms, start_time;
diff --git a/src/window.c b/src/window.c
index e8798f1e3ee..c3e693182c6 100644
--- a/src/window.c
+++ b/src/window.c
@@ -6008,7 +6008,7 @@ struct save_window_data
6008 struct vectorlike_header header; 6008 struct vectorlike_header header;
6009 Lisp_Object selected_frame; 6009 Lisp_Object selected_frame;
6010 Lisp_Object current_window; 6010 Lisp_Object current_window;
6011 Lisp_Object current_buffer; 6011 Lisp_Object f_current_buffer;
6012 Lisp_Object minibuf_scroll_window; 6012 Lisp_Object minibuf_scroll_window;
6013 Lisp_Object minibuf_selected_window; 6013 Lisp_Object minibuf_selected_window;
6014 Lisp_Object root_window; 6014 Lisp_Object root_window;
@@ -6098,7 +6098,7 @@ the return value is nil. Otherwise the value is t. */)
6098 data = (struct save_window_data *) XVECTOR (configuration); 6098 data = (struct save_window_data *) XVECTOR (configuration);
6099 saved_windows = XVECTOR (data->saved_windows); 6099 saved_windows = XVECTOR (data->saved_windows);
6100 6100
6101 new_current_buffer = data->current_buffer; 6101 new_current_buffer = data->f_current_buffer;
6102 if (!BUFFER_LIVE_P (XBUFFER (new_current_buffer))) 6102 if (!BUFFER_LIVE_P (XBUFFER (new_current_buffer)))
6103 new_current_buffer = Qnil; 6103 new_current_buffer = Qnil;
6104 else 6104 else
@@ -6750,7 +6750,7 @@ saved by this function. */)
6750 data->frame_tool_bar_height = FRAME_TOOL_BAR_HEIGHT (f); 6750 data->frame_tool_bar_height = FRAME_TOOL_BAR_HEIGHT (f);
6751 data->selected_frame = selected_frame; 6751 data->selected_frame = selected_frame;
6752 data->current_window = FRAME_SELECTED_WINDOW (f); 6752 data->current_window = FRAME_SELECTED_WINDOW (f);
6753 XSETBUFFER (data->current_buffer, current_buffer); 6753 XSETBUFFER (data->f_current_buffer, current_buffer);
6754 data->minibuf_scroll_window = minibuf_level > 0 ? Vminibuf_scroll_window : Qnil; 6754 data->minibuf_scroll_window = minibuf_level > 0 ? Vminibuf_scroll_window : Qnil;
6755 data->minibuf_selected_window = minibuf_level > 0 ? minibuf_selected_window : Qnil; 6755 data->minibuf_selected_window = minibuf_level > 0 ? minibuf_selected_window : Qnil;
6756 data->root_window = FRAME_ROOT_WINDOW (f); 6756 data->root_window = FRAME_ROOT_WINDOW (f);
@@ -7205,7 +7205,7 @@ compare_window_configurations (Lisp_Object configuration1,
7205 || d1->frame_lines != d2->frame_lines 7205 || d1->frame_lines != d2->frame_lines
7206 || d1->frame_menu_bar_lines != d2->frame_menu_bar_lines 7206 || d1->frame_menu_bar_lines != d2->frame_menu_bar_lines
7207 || !EQ (d1->selected_frame, d2->selected_frame) 7207 || !EQ (d1->selected_frame, d2->selected_frame)
7208 || !EQ (d1->current_buffer, d2->current_buffer) 7208 || !EQ (d1->f_current_buffer, d2->f_current_buffer)
7209 || (!ignore_positions 7209 || (!ignore_positions
7210 && (!EQ (d1->minibuf_scroll_window, d2->minibuf_scroll_window) 7210 && (!EQ (d1->minibuf_scroll_window, d2->minibuf_scroll_window)
7211 || !EQ (d1->minibuf_selected_window, d2->minibuf_selected_window))) 7211 || !EQ (d1->minibuf_selected_window, d2->minibuf_selected_window)))
diff --git a/src/xgselect.c b/src/xgselect.c
index 7850a16e9c0..2f23764ae41 100644
--- a/src/xgselect.c
+++ b/src/xgselect.c
@@ -54,9 +54,8 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds,
54 int gfds_size = ARRAYELTS (gfds_buf); 54 int gfds_size = ARRAYELTS (gfds_buf);
55 int n_gfds, retval = 0, our_fds = 0, max_fds = fds_lim - 1; 55 int n_gfds, retval = 0, our_fds = 0, max_fds = fds_lim - 1;
56 bool context_acquired = false; 56 bool context_acquired = false;
57 int i, nfds, tmo_in_millisec; 57 int i, nfds, tmo_in_millisec, must_free = 0;
58 bool need_to_dispatch; 58 bool need_to_dispatch;
59 USE_SAFE_ALLOCA;
60 59
61 context = g_main_context_default (); 60 context = g_main_context_default ();
62 context_acquired = g_main_context_acquire (context); 61 context_acquired = g_main_context_acquire (context);
@@ -77,7 +76,11 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds,
77 76
78 if (gfds_size < n_gfds) 77 if (gfds_size < n_gfds)
79 { 78 {
80 SAFE_NALLOCA (gfds, sizeof *gfds, n_gfds); 79 /* Avoid using SAFE_NALLOCA, as that implicitly refers to the
80 current thread. Using xnmalloc avoids thread-switching
81 problems here. */
82 gfds = xnmalloc (n_gfds, sizeof *gfds);
83 must_free = 1;
81 gfds_size = n_gfds; 84 gfds_size = n_gfds;
82 n_gfds = g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec, 85 n_gfds = g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec,
83 gfds, gfds_size); 86 gfds, gfds_size);
@@ -98,7 +101,8 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds,
98 } 101 }
99 } 102 }
100 103
101 SAFE_FREE (); 104 if (must_free)
105 xfree (gfds);
102 106
103 if (n_gfds >= 0 && tmo_in_millisec >= 0) 107 if (n_gfds >= 0 && tmo_in_millisec >= 0)
104 { 108 {
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-18 19:21:33 +0000