aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authorEli Zaretskii2016-12-04 19:59:17 +0200
committerEli Zaretskii2016-12-04 19:59:17 +0200
commitde4624c99ea5bbe38ad5aff7b6461cc5c740d0be (patch)
tree1b57de9e769cdb695cb2cecf157b50f7dea9cfe5 /src
parenta486fabb41cdbaa5813c2687fd4008945297d71d (diff)
parente7bde34e939451d87fb42a36195086bdbe48b5e1 (diff)
downloademacs-de4624c99ea5bbe38ad5aff7b6461cc5c740d0be.tar.gz
emacs-de4624c99ea5bbe38ad5aff7b6461cc5c740d0be.zip
Merge branch 'concurrency'
Conflicts (resolved): configure.ac src/Makefile.in src/alloc.c src/bytecode.c src/emacs.c src/eval.c src/lisp.h src/process.c src/regex.c src/regex.h
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.c200
-rw-r--r--src/data.c39
-rw-r--r--src/emacs.c14
-rw-r--r--src/eval.c249
-rw-r--r--src/lisp.h163
-rw-r--r--src/print.c36
-rw-r--r--src/process.c542
-rw-r--r--src/process.h5
-rw-r--r--src/regex.c21
-rw-r--r--src/regex.h8
-rw-r--r--src/search.c22
-rw-r--r--src/sysdep.c13
-rw-r--r--src/systhread.c417
-rw-r--r--src/systhread.h112
-rw-r--r--src/thread.c975
-rw-r--r--src/thread.h248
-rw-r--r--src/w32.c2
-rw-r--r--src/w32.h1
-rw-r--r--src/w32proc.c2
-rw-r--r--src/window.c8
-rw-r--r--src/xgselect.c9
26 files changed, 2780 insertions, 441 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 dc0bfff9b33..a8c12848cee 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 868c0148d30..3ac94055f33 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
@@ -666,72 +753,85 @@ 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 }
698 NEXT; 781 NEXT;
699 782
700 CASE (Bgotoifnonnilelsepop): 783 CASE (Bgotoifnonnilelsepop):
701 op = FETCH2; 784 op = FETCH2;
702 if (!NILP (TOP)) 785 if (!NILP (TOP))
703 goto op_branch; 786 {
704 DISCARD (1); 787 BYTE_CODE_QUIT;
788 CHECK_RANGE (op);
789 stack.pc = stack.byte_string_start + op;
790 }
791 else DISCARD (1);
705 NEXT; 792 NEXT;
706 793
707 CASE (BRgoto): 794 CASE (BRgoto):
708 op = FETCH - 128; 795 BYTE_CODE_QUIT;
709 goto op_relative_branch; 796 stack.pc += (int) *stack.pc - 127;
797 NEXT;
710 798
711 CASE (BRgotoifnil): 799 CASE (BRgotoifnil):
712 op = FETCH - 128;
713 if (NILP (POP)) 800 if (NILP (POP))
714 goto op_relative_branch; 801 {
802 BYTE_CODE_QUIT;
803 stack.pc += (int) *stack.pc - 128;
804 }
805 stack.pc++;
715 NEXT; 806 NEXT;
716 807
717 CASE (BRgotoifnonnil): 808 CASE (BRgotoifnonnil):
718 op = FETCH - 128;
719 if (!NILP (POP)) 809 if (!NILP (POP))
720 goto op_relative_branch; 810 {
811 BYTE_CODE_QUIT;
812 stack.pc += (int) *stack.pc - 128;
813 }
814 stack.pc++;
721 NEXT; 815 NEXT;
722 816
723 CASE (BRgotoifnilelsepop): 817 CASE (BRgotoifnilelsepop):
724 op = FETCH - 128; 818 op = *stack.pc++;
725 if (NILP (TOP)) 819 if (NILP (TOP))
726 goto op_relative_branch; 820 {
727 DISCARD (1); 821 BYTE_CODE_QUIT;
822 stack.pc += op - 128;
823 }
824 else DISCARD (1);
728 NEXT; 825 NEXT;
729 826
730 CASE (BRgotoifnonnilelsepop): 827 CASE (BRgotoifnonnilelsepop):
731 op = FETCH - 128; 828 op = *stack.pc++;
732 if (!NILP (TOP)) 829 if (!NILP (TOP))
733 goto op_relative_branch; 830 {
734 DISCARD (1); 831 BYTE_CODE_QUIT;
832 stack.pc += op - 128;
833 }
834 else DISCARD (1);
735 NEXT; 835 NEXT;
736 836
737 CASE (Breturn): 837 CASE (Breturn):
@@ -791,11 +891,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
791 if (sys_setjmp (c->jmp)) 891 if (sys_setjmp (c->jmp))
792 { 892 {
793 struct handler *c = handlerlist; 893 struct handler *c = handlerlist;
894 int desc;
794 top = c->bytecode_top; 895 top = c->bytecode_top;
795 op = c->bytecode_dest; 896 dest = c->bytecode_dest;
796 handlerlist = c->next; 897 handlerlist = c->next;
797 PUSH (c->val); 898 PUSH (c->val);
798 goto op_branch; 899 CHECK_RANGE (dest);
900 /* Might have been re-set by longjmp! */
901 stack.byte_string_start = SDATA (stack.byte_string);
902 stack.pc = stack.byte_string_start + dest;
799 } 903 }
800 904
801 NEXT; 905 NEXT;
@@ -1364,7 +1468,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
1364 call3 (Qerror, 1468 call3 (Qerror,
1365 build_string ("Invalid byte opcode: op=%s, ptr=%d"), 1469 build_string ("Invalid byte opcode: op=%s, ptr=%d"),
1366 make_number (op), 1470 make_number (op),
1367 make_number (pc - 1 - bytestr_data)); 1471 make_number (stack.pc - 1 - stack.byte_string_start));
1368 1472
1369 /* Handy byte-codes for lexical binding. */ 1473 /* Handy byte-codes for lexical binding. */
1370 CASE (Bstack_ref1): 1474 CASE (Bstack_ref1):
@@ -1424,6 +1528,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
1424 1528
1425 exit: 1529 exit:
1426 1530
1531 byte_stack_list = byte_stack_list->next;
1532
1427 /* Binds and unbinds are supposed to be compiled balanced. */ 1533 /* Binds and unbinds are supposed to be compiled balanced. */
1428 if (SPECPDL_INDEX () != count) 1534 if (SPECPDL_INDEX () != count)
1429 { 1535 {
diff --git a/src/data.c b/src/data.c
index eee2a52a37a..711f67d1df1 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 f633f09098d..bf2f5588d1c 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);
@@ -878,9 +874,6 @@ main (int argc, char **argv)
878 } 874 }
879#endif /* HAVE_SETRLIMIT and RLIMIT_STACK and not CYGWIN */ 875#endif /* HAVE_SETRLIMIT and RLIMIT_STACK and not CYGWIN */
880 876
881 /* Record (approximately) where the stack begins. */
882 stack_bottom = &stack_bottom_variable;
883
884 clearerr (stdin); 877 clearerr (stdin);
885 878
886 emacs_backtrace (-1); 879 emacs_backtrace (-1);
@@ -1194,6 +1187,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
1194 if (!initialized) 1187 if (!initialized)
1195 { 1188 {
1196 init_alloc_once (); 1189 init_alloc_once ();
1190 init_threads_once ();
1197 init_obarray (); 1191 init_obarray ();
1198 init_eval_once (); 1192 init_eval_once ();
1199 init_charset_once (); 1193 init_charset_once ();
@@ -1240,6 +1234,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
1240 } 1234 }
1241 1235
1242 init_alloc (); 1236 init_alloc ();
1237 init_threads ();
1243 1238
1244 if (do_initial_setlocale) 1239 if (do_initial_setlocale)
1245 { 1240 {
@@ -1582,6 +1577,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
1582#endif /* HAVE_W32NOTIFY */ 1577#endif /* HAVE_W32NOTIFY */
1583#endif /* WINDOWSNT */ 1578#endif /* WINDOWSNT */
1584 1579
1580 syms_of_threads ();
1585 syms_of_profiler (); 1581 syms_of_profiler ();
1586 1582
1587 keys_of_casefiddle (); 1583 keys_of_casefiddle ();
diff --git a/src/eval.c b/src/eval.c
index 724f0018a58..c08f93aee0c 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
@@ -122,6 +124,13 @@ specpdl_where (union specbinding *pdl)
122} 124}
123 125
124static Lisp_Object 126static Lisp_Object
127specpdl_saved_value (union specbinding *pdl)
128{
129 eassert (pdl->kind >= SPECPDL_LET);
130 return pdl->let.saved_value;
131}
132
133static Lisp_Object
125specpdl_arg (union specbinding *pdl) 134specpdl_arg (union specbinding *pdl)
126{ 135{
127 eassert (pdl->kind == SPECPDL_UNWIND); 136 eassert (pdl->kind == SPECPDL_UNWIND);
@@ -218,20 +227,22 @@ init_eval_once (void)
218 Vrun_hooks = Qnil; 227 Vrun_hooks = Qnil;
219} 228}
220 229
221static struct handler handlerlist_sentinel; 230/* static struct handler handlerlist_sentinel; */
222 231
223void 232void
224init_eval (void) 233init_eval (void)
225{ 234{
235 byte_stack_list = 0;
226 specpdl_ptr = specpdl; 236 specpdl_ptr = specpdl;
227 { /* Put a dummy catcher at top-level so that handlerlist is never NULL. 237 { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
228 This is important since handlerlist->nextfree holds the freelist 238 This is important since handlerlist->nextfree holds the freelist
229 which would otherwise leak every time we unwind back to top-level. */ 239 which would otherwise leak every time we unwind back to top-level. */
230 handlerlist = handlerlist_sentinel.nextfree = &handlerlist_sentinel; 240 handlerlist_sentinel = xzalloc (sizeof (struct handler));
241 handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
231 struct handler *c = push_handler (Qunbound, CATCHER); 242 struct handler *c = push_handler (Qunbound, CATCHER);
232 eassert (c == &handlerlist_sentinel); 243 eassert (c == handlerlist_sentinel);
233 handlerlist_sentinel.nextfree = NULL; 244 handlerlist_sentinel->nextfree = NULL;
234 handlerlist_sentinel.next = NULL; 245 handlerlist_sentinel->next = NULL;
235 } 246 }
236 Vquit_flag = Qnil; 247 Vquit_flag = Qnil;
237 debug_on_next_call = 0; 248 debug_on_next_call = 0;
@@ -1138,7 +1149,8 @@ unwind_to_catch (struct handler *catch, Lisp_Object value)
1138 1149
1139 eassert (handlerlist == catch); 1150 eassert (handlerlist == catch);
1140 1151
1141 lisp_eval_depth = catch->lisp_eval_depth; 1152 byte_stack_list = catch->byte_stack;
1153 lisp_eval_depth = catch->f_lisp_eval_depth;
1142 1154
1143 sys_longjmp (catch->jmp, 1); 1155 sys_longjmp (catch->jmp, 1);
1144} 1156}
@@ -1432,6 +1444,7 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
1432 c->pdlcount = SPECPDL_INDEX (); 1444 c->pdlcount = SPECPDL_INDEX ();
1433 c->poll_suppress_count = poll_suppress_count; 1445 c->poll_suppress_count = poll_suppress_count;
1434 c->interrupt_input_blocked = interrupt_input_blocked; 1446 c->interrupt_input_blocked = interrupt_input_blocked;
1447 c->byte_stack = byte_stack_list;
1435 handlerlist = c; 1448 handlerlist = c;
1436 return c; 1449 return c;
1437} 1450}
@@ -1581,7 +1594,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
1581 } 1594 }
1582 else 1595 else
1583 { 1596 {
1584 if (handlerlist != &handlerlist_sentinel) 1597 if (handlerlist != handlerlist_sentinel)
1585 /* FIXME: This will come right back here if there's no `top-level' 1598 /* 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 1599 catcher. A better solution would be to abort here, and instead
1587 add a catch-all condition handler so we never come here. */ 1600 add a catch-all condition handler so we never come here. */
@@ -3144,6 +3157,44 @@ let_shadows_global_binding_p (Lisp_Object symbol)
3144 return 0; 3157 return 0;
3145} 3158}
3146 3159
3160void
3161do_specbind (struct Lisp_Symbol *sym, union specbinding *bind,
3162 Lisp_Object value)
3163{
3164 switch (sym->redirect)
3165 {
3166 case SYMBOL_PLAINVAL:
3167 if (!sym->trapped_write)
3168 SET_SYMBOL_VAL (sym, value);
3169 else
3170 set_internal (specpdl_symbol (bind), value, Qnil, SET_INTERNAL_BIND);
3171 break;
3172
3173 case SYMBOL_LOCALIZED:
3174 case SYMBOL_FORWARDED:
3175 if ((sym->redirect == SYMBOL_LOCALIZED
3176 || BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
3177 && CONSP (specpdl_symbol (bind)))
3178 {
3179 Lisp_Object where;
3180
3181 where = XCAR (XCDR (specpdl_symbol (bind)));
3182 if (NILP (where)
3183 && sym->redirect == SYMBOL_FORWARDED)
3184 {
3185 Fset_default (XCAR (specpdl_symbol (bind)), value);
3186 return;
3187 }
3188 }
3189
3190 set_internal (specpdl_symbol (bind), value, Qnil, SET_INTERNAL_BIND);
3191 break;
3192
3193 default:
3194 emacs_abort ();
3195 }
3196}
3197
3147/* `specpdl_ptr' describes which variable is 3198/* `specpdl_ptr' describes which variable is
3148 let-bound, so it can be properly undone when we unbind_to. 3199 let-bound, so it can be properly undone when we unbind_to.
3149 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT. 3200 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
@@ -3175,11 +3226,9 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3175 specpdl_ptr->let.kind = SPECPDL_LET; 3226 specpdl_ptr->let.kind = SPECPDL_LET;
3176 specpdl_ptr->let.symbol = symbol; 3227 specpdl_ptr->let.symbol = symbol;
3177 specpdl_ptr->let.old_value = SYMBOL_VAL (sym); 3228 specpdl_ptr->let.old_value = SYMBOL_VAL (sym);
3229 specpdl_ptr->let.saved_value = Qnil;
3178 grow_specpdl (); 3230 grow_specpdl ();
3179 if (!sym->trapped_write) 3231 do_specbind (sym, specpdl_ptr - 1, value);
3180 SET_SYMBOL_VAL (sym, value);
3181 else
3182 set_internal (symbol, value, Qnil, SET_INTERNAL_BIND);
3183 break; 3232 break;
3184 case SYMBOL_LOCALIZED: 3233 case SYMBOL_LOCALIZED:
3185 if (SYMBOL_BLV (sym)->frame_local) 3234 if (SYMBOL_BLV (sym)->frame_local)
@@ -3191,6 +3240,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3191 specpdl_ptr->let.symbol = symbol; 3240 specpdl_ptr->let.symbol = symbol;
3192 specpdl_ptr->let.old_value = ovalue; 3241 specpdl_ptr->let.old_value = ovalue;
3193 specpdl_ptr->let.where = Fcurrent_buffer (); 3242 specpdl_ptr->let.where = Fcurrent_buffer ();
3243 specpdl_ptr->let.saved_value = Qnil;
3194 3244
3195 eassert (sym->redirect != SYMBOL_LOCALIZED 3245 eassert (sym->redirect != SYMBOL_LOCALIZED
3196 || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ()))); 3246 || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
@@ -3211,7 +3261,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3211 { 3261 {
3212 specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT; 3262 specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
3213 grow_specpdl (); 3263 grow_specpdl ();
3214 Fset_default (symbol, value); 3264 do_specbind (sym, specpdl_ptr - 1, value);
3215 return; 3265 return;
3216 } 3266 }
3217 } 3267 }
@@ -3219,7 +3269,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3219 specpdl_ptr->let.kind = SPECPDL_LET; 3269 specpdl_ptr->let.kind = SPECPDL_LET;
3220 3270
3221 grow_specpdl (); 3271 grow_specpdl ();
3222 set_internal (symbol, value, Qnil, SET_INTERNAL_BIND); 3272 do_specbind (sym, specpdl_ptr - 1, value);
3223 break; 3273 break;
3224 } 3274 }
3225 default: emacs_abort (); 3275 default: emacs_abort ();
@@ -3263,7 +3313,84 @@ record_unwind_protect_void (void (*function) (void))
3263 grow_specpdl (); 3313 grow_specpdl ();
3264} 3314}
3265 3315
3316void
3317rebind_for_thread_switch (void)
3318{
3319 union specbinding *bind;
3320
3321 for (bind = specpdl; bind != specpdl_ptr; ++bind)
3322 {
3323 if (bind->kind >= SPECPDL_LET)
3324 {
3325 Lisp_Object value = specpdl_saved_value (bind);
3326
3327 bind->let.saved_value = Qnil;
3328 do_specbind (XSYMBOL (specpdl_symbol (bind)), bind, value);
3329 }
3330 }
3331}
3332
3266static void 3333static void
3334do_one_unbind (union specbinding *this_binding, int unwinding)
3335{
3336 eassert (unwinding || this_binding->kind >= SPECPDL_LET);
3337 switch (this_binding->kind)
3338 {
3339 case SPECPDL_UNWIND:
3340 this_binding->unwind.func (this_binding->unwind.arg);
3341 break;
3342 case SPECPDL_UNWIND_PTR:
3343 this_binding->unwind_ptr.func (this_binding->unwind_ptr.arg);
3344 break;
3345 case SPECPDL_UNWIND_INT:
3346 this_binding->unwind_int.func (this_binding->unwind_int.arg);
3347 break;
3348 case SPECPDL_UNWIND_VOID:
3349 this_binding->unwind_void.func ();
3350 break;
3351 case SPECPDL_BACKTRACE:
3352 break;
3353 case SPECPDL_LET:
3354 { /* If variable has a trivial value (no forwarding), and isn't
3355 trapped we can just set it. No need to check for constant
3356 symbols here, since that was already done by specbind. */
3357 struct Lisp_Symbol sym = specpdl_symbol (this_binding);
3358 if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL)
3359 {
3360 if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE)
3361 SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value (this_binding));
3362 else
3363 set_internal (sym, specpdl_old_value (this_binding),
3364 Qnil, SET_INTERNAL_UNBIND);
3365 break;
3366 }
3367 else
3368 { /* FALLTHROUGH!!
3369 NOTE: we only ever come here if make_local_foo was used for
3370 the first time on this var within this let. */
3371 }
3372 }
3373 case SPECPDL_LET_DEFAULT:
3374 Fset_default (specpdl_symbol (this_binding),
3375 specpdl_old_value (this_binding));
3376 break;
3377 case SPECPDL_LET_LOCAL:
3378 {
3379 Lisp_Object symbol = specpdl_symbol (this_binding);
3380 Lisp_Object where = specpdl_where (this_binding);
3381 Lisp_Object old_value = specpdl_old_value (this_binding);
3382 eassert (BUFFERP (where));
3383
3384 /* If this was a local binding, reset the value in the appropriate
3385 buffer, but only if that buffer's binding still exists. */
3386 if (!NILP (Flocal_variable_p (symbol, where)))
3387 set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND);
3388 }
3389 break;
3390 }
3391}
3392
3393void
3267do_nothing (void) 3394do_nothing (void)
3268{} 3395{}
3269 3396
@@ -3322,66 +3449,16 @@ unbind_to (ptrdiff_t count, Lisp_Object value)
3322 3449
3323 while (specpdl_ptr != specpdl + count) 3450 while (specpdl_ptr != specpdl + count)
3324 { 3451 {
3325 /* Decrement specpdl_ptr before we do the work to unbind it, so 3452 /* Copy the binding, and decrement specpdl_ptr, before we do
3326 that an error in unbinding won't try to unbind the same entry 3453 the work to unbind it. We decrement first
3327 again. Take care to copy any parts of the binding needed 3454 so that an error in unbinding won't try to unbind
3328 before invoking any code that can make more bindings. */ 3455 the same entry again, and we copy the binding first
3456 in case more bindings are made during some of the code we run. */
3329 3457
3330 specpdl_ptr--; 3458 union specbinding this_binding;
3459 this_binding = *--specpdl_ptr;
3331 3460
3332 switch (specpdl_ptr->kind) 3461 do_one_unbind (&this_binding, 1);
3333 {
3334 case SPECPDL_UNWIND:
3335 specpdl_ptr->unwind.func (specpdl_ptr->unwind.arg);
3336 break;
3337 case SPECPDL_UNWIND_PTR:
3338 specpdl_ptr->unwind_ptr.func (specpdl_ptr->unwind_ptr.arg);
3339 break;
3340 case SPECPDL_UNWIND_INT:
3341 specpdl_ptr->unwind_int.func (specpdl_ptr->unwind_int.arg);
3342 break;
3343 case SPECPDL_UNWIND_VOID:
3344 specpdl_ptr->unwind_void.func ();
3345 break;
3346 case SPECPDL_BACKTRACE:
3347 break;
3348 case SPECPDL_LET:
3349 { /* If variable has a trivial value (no forwarding), and
3350 isn't trapped, we can just set it. */
3351 Lisp_Object sym = specpdl_symbol (specpdl_ptr);
3352 if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL)
3353 {
3354 if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE)
3355 SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value (specpdl_ptr));
3356 else
3357 set_internal (sym, specpdl_old_value (specpdl_ptr),
3358 Qnil, SET_INTERNAL_UNBIND);
3359 break;
3360 }
3361 else
3362 { /* FALLTHROUGH!!
3363 NOTE: we only ever come here if make_local_foo was used for
3364 the first time on this var within this let. */
3365 }
3366 }
3367 case SPECPDL_LET_DEFAULT:
3368 Fset_default (specpdl_symbol (specpdl_ptr),
3369 specpdl_old_value (specpdl_ptr));
3370 break;
3371 case SPECPDL_LET_LOCAL:
3372 {
3373 Lisp_Object symbol = specpdl_symbol (specpdl_ptr);
3374 Lisp_Object where = specpdl_where (specpdl_ptr);
3375 Lisp_Object old_value = specpdl_old_value (specpdl_ptr);
3376 eassert (BUFFERP (where));
3377
3378 /* If this was a local binding, reset the value in the appropriate
3379 buffer, but only if that buffer's binding still exists. */
3380 if (!NILP (Flocal_variable_p (symbol, where)))
3381 set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND);
3382 }
3383 break;
3384 }
3385 } 3462 }
3386 3463
3387 if (NILP (Vquit_flag) && !NILP (quitf)) 3464 if (NILP (Vquit_flag) && !NILP (quitf))
@@ -3390,6 +3467,21 @@ unbind_to (ptrdiff_t count, Lisp_Object value)
3390 return value; 3467 return value;
3391} 3468}
3392 3469
3470void
3471unbind_for_thread_switch (struct thread_state *thr)
3472{
3473 union specbinding *bind;
3474
3475 for (bind = thr->m_specpdl_ptr; bind > thr->m_specpdl;)
3476 {
3477 if ((--bind)->kind >= SPECPDL_LET)
3478 {
3479 bind->let.saved_value = find_symbol_value (specpdl_symbol (bind));
3480 do_one_unbind (bind, 0);
3481 }
3482 }
3483}
3484
3393DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0, 3485DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
3394 doc: /* Return non-nil if SYMBOL's global binding has been declared special. 3486 doc: /* Return non-nil if SYMBOL's global binding has been declared special.
3395A special variable is one that will be bound dynamically, even in a 3487A special variable is one that will be bound dynamically, even in a
@@ -3712,10 +3804,10 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'.
3712 3804
3713 3805
3714void 3806void
3715mark_specpdl (void) 3807mark_specpdl (union specbinding *first, union specbinding *ptr)
3716{ 3808{
3717 union specbinding *pdl; 3809 union specbinding *pdl;
3718 for (pdl = specpdl; pdl != specpdl_ptr; pdl++) 3810 for (pdl = first; pdl != ptr; pdl++)
3719 { 3811 {
3720 switch (pdl->kind) 3812 switch (pdl->kind)
3721 { 3813 {
@@ -3741,6 +3833,7 @@ mark_specpdl (void)
3741 case SPECPDL_LET: 3833 case SPECPDL_LET:
3742 mark_object (specpdl_symbol (pdl)); 3834 mark_object (specpdl_symbol (pdl));
3743 mark_object (specpdl_old_value (pdl)); 3835 mark_object (specpdl_old_value (pdl));
3836 mark_object (specpdl_saved_value (pdl));
3744 break; 3837 break;
3745 3838
3746 case SPECPDL_UNWIND_PTR: 3839 case SPECPDL_UNWIND_PTR:
diff --git a/src/lisp.h b/src/lisp.h
index 94f1152a56e..d4da32e3ebf 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:
@@ -590,6 +592,9 @@ INLINE bool (SYMBOLP) (Lisp_Object);
590INLINE bool (VECTORLIKEP) (Lisp_Object); 592INLINE bool (VECTORLIKEP) (Lisp_Object);
591INLINE bool WINDOWP (Lisp_Object); 593INLINE bool WINDOWP (Lisp_Object);
592INLINE bool TERMINALP (Lisp_Object); 594INLINE bool TERMINALP (Lisp_Object);
595INLINE bool THREADP (Lisp_Object);
596INLINE bool MUTEXP (Lisp_Object);
597INLINE bool CONDVARP (Lisp_Object);
593INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object); 598INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object);
594INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object); 599INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object);
595INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object); 600INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object);
@@ -758,6 +763,39 @@ struct Lisp_Symbol
758 763
759#include "globals.h" 764#include "globals.h"
760 765
766/* Header of vector-like objects. This documents the layout constraints on
767 vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
768 compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
769 and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
770 because when two such pointers potentially alias, a compiler won't
771 incorrectly reorder loads and stores to their size fields. See
772 Bug#8546. */
773struct vectorlike_header
774 {
775 /* The only field contains various pieces of information:
776 - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
777 - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
778 vector (0) or a pseudovector (1).
779 - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
780 of slots) of the vector.
781 - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
782 - a) pseudovector subtype held in PVEC_TYPE_MASK field;
783 - b) number of Lisp_Objects slots at the beginning of the object
784 held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
785 traced by the GC;
786 - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
787 measured in word_size units. Rest fields may also include
788 Lisp_Objects, but these objects usually needs some special treatment
789 during GC.
790 There are some exceptions. For PVEC_FREE, b) is always zero. For
791 PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
792 Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
793 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
794 ptrdiff_t size;
795 };
796
797#include "thread.h"
798
761/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa. 799/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa.
762 At the machine level, these operations are no-ops. */ 800 At the machine level, these operations are no-ops. */
763 801
@@ -804,7 +842,9 @@ enum pvec_type
804 PVEC_OTHER, 842 PVEC_OTHER,
805 PVEC_XWIDGET, 843 PVEC_XWIDGET,
806 PVEC_XWIDGET_VIEW, 844 PVEC_XWIDGET_VIEW,
807 845 PVEC_THREAD,
846 PVEC_MUTEX,
847 PVEC_CONDVAR,
808 /* These should be last, check internal_equal to see why. */ 848 /* These should be last, check internal_equal to see why. */
809 PVEC_COMPILED, 849 PVEC_COMPILED,
810 PVEC_CHAR_TABLE, 850 PVEC_CHAR_TABLE,
@@ -1107,6 +1147,27 @@ XBOOL_VECTOR (Lisp_Object a)
1107 return XUNTAG (a, Lisp_Vectorlike); 1147 return XUNTAG (a, Lisp_Vectorlike);
1108} 1148}
1109 1149
1150INLINE struct thread_state *
1151XTHREAD (Lisp_Object a)
1152{
1153 eassert (THREADP (a));
1154 return XUNTAG (a, Lisp_Vectorlike);
1155}
1156
1157INLINE struct Lisp_Mutex *
1158XMUTEX (Lisp_Object a)
1159{
1160 eassert (MUTEXP (a));
1161 return XUNTAG (a, Lisp_Vectorlike);
1162}
1163
1164INLINE struct Lisp_CondVar *
1165XCONDVAR (Lisp_Object a)
1166{
1167 eassert (CONDVARP (a));
1168 return XUNTAG (a, Lisp_Vectorlike);
1169}
1170
1110/* Construct a Lisp_Object from a value or address. */ 1171/* Construct a Lisp_Object from a value or address. */
1111 1172
1112INLINE Lisp_Object 1173INLINE Lisp_Object
@@ -1173,6 +1234,9 @@ builtin_lisp_symbol (int index)
1173#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) 1234#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
1174#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) 1235#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
1175#define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE)) 1236#define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE))
1237#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD))
1238#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX))
1239#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR))
1176 1240
1177/* Efficiently convert a pointer to a Lisp object and back. The 1241/* Efficiently convert a pointer to a Lisp object and back. The
1178 pointer is represented as a Lisp integer, so the garbage collector 1242 pointer is represented as a Lisp integer, so the garbage collector
@@ -1400,37 +1464,6 @@ STRING_SET_CHARS (Lisp_Object string, ptrdiff_t newsize)
1400 XSTRING (string)->size = newsize; 1464 XSTRING (string)->size = newsize;
1401} 1465}
1402 1466
1403/* Header of vector-like objects. This documents the layout constraints on
1404 vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
1405 compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
1406 and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
1407 because when two such pointers potentially alias, a compiler won't
1408 incorrectly reorder loads and stores to their size fields. See
1409 Bug#8546. */
1410struct vectorlike_header
1411 {
1412 /* The only field contains various pieces of information:
1413 - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
1414 - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
1415 vector (0) or a pseudovector (1).
1416 - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
1417 of slots) of the vector.
1418 - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
1419 - a) pseudovector subtype held in PVEC_TYPE_MASK field;
1420 - b) number of Lisp_Objects slots at the beginning of the object
1421 held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
1422 traced by the GC;
1423 - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
1424 measured in word_size units. Rest fields may also include
1425 Lisp_Objects, but these objects usually needs some special treatment
1426 during GC.
1427 There are some exceptions. For PVEC_FREE, b) is always zero. For
1428 PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
1429 Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
1430 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
1431 ptrdiff_t size;
1432 };
1433
1434/* A regular vector is just a header plus an array of Lisp_Objects. */ 1467/* A regular vector is just a header plus an array of Lisp_Objects. */
1435 1468
1436struct Lisp_Vector 1469struct Lisp_Vector
@@ -2780,6 +2813,24 @@ FRAMEP (Lisp_Object a)
2780 return PSEUDOVECTORP (a, PVEC_FRAME); 2813 return PSEUDOVECTORP (a, PVEC_FRAME);
2781} 2814}
2782 2815
2816INLINE bool
2817THREADP (Lisp_Object a)
2818{
2819 return PSEUDOVECTORP (a, PVEC_THREAD);
2820}
2821
2822INLINE bool
2823MUTEXP (Lisp_Object a)
2824{
2825 return PSEUDOVECTORP (a, PVEC_MUTEX);
2826}
2827
2828INLINE bool
2829CONDVARP (Lisp_Object a)
2830{
2831 return PSEUDOVECTORP (a, PVEC_CONDVAR);
2832}
2833
2783/* Test for image (image . spec) */ 2834/* Test for image (image . spec) */
2784INLINE bool 2835INLINE bool
2785IMAGEP (Lisp_Object x) 2836IMAGEP (Lisp_Object x)
@@ -2928,6 +2979,25 @@ CHECK_NUMBER_OR_FLOAT (Lisp_Object x)
2928 CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \ 2979 CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \
2929 } while (false) 2980 } while (false)
2930 2981
2982
2983INLINE void
2984CHECK_THREAD (Lisp_Object x)
2985{
2986 CHECK_TYPE (THREADP (x), Qthreadp, x);
2987}
2988
2989INLINE void
2990CHECK_MUTEX (Lisp_Object x)
2991{
2992 CHECK_TYPE (MUTEXP (x), Qmutexp, x);
2993}
2994
2995INLINE void
2996CHECK_CONDVAR (Lisp_Object x)
2997{
2998 CHECK_TYPE (CONDVARP (x), Qcondition_variable_p, x);
2999}
3000
2931/* Since we can't assign directly to the CAR or CDR fields of a cons 3001/* Since we can't assign directly to the CAR or CDR fields of a cons
2932 cell, use these when checking that those fields contain numbers. */ 3002 cell, use these when checking that those fields contain numbers. */
2933INLINE void 3003INLINE void
@@ -3146,6 +3216,9 @@ union specbinding
3146 ENUM_BF (specbind_tag) kind : CHAR_BIT; 3216 ENUM_BF (specbind_tag) kind : CHAR_BIT;
3147 /* `where' is not used in the case of SPECPDL_LET. */ 3217 /* `where' is not used in the case of SPECPDL_LET. */
3148 Lisp_Object symbol, old_value, where; 3218 Lisp_Object symbol, old_value, where;
3219 /* Normally this is unused; but it is set to the symbol's
3220 current value when a thread is swapped out. */
3221 Lisp_Object saved_value;
3149 } let; 3222 } let;
3150 struct { 3223 struct {
3151 ENUM_BF (specbind_tag) kind : CHAR_BIT; 3224 ENUM_BF (specbind_tag) kind : CHAR_BIT;
@@ -3156,9 +3229,9 @@ union specbinding
3156 } bt; 3229 } bt;
3157 }; 3230 };
3158 3231
3159extern union specbinding *specpdl; 3232/* extern union specbinding *specpdl; */
3160extern union specbinding *specpdl_ptr; 3233/* extern union specbinding *specpdl_ptr; */
3161extern ptrdiff_t specpdl_size; 3234/* extern ptrdiff_t specpdl_size; */
3162 3235
3163INLINE ptrdiff_t 3236INLINE ptrdiff_t
3164SPECPDL_INDEX (void) 3237SPECPDL_INDEX (void)
@@ -3209,18 +3282,15 @@ struct handler
3209 /* Most global vars are reset to their value via the specpdl mechanism, 3282 /* Most global vars are reset to their value via the specpdl mechanism,
3210 but a few others are handled by storing their value here. */ 3283 but a few others are handled by storing their value here. */
3211 sys_jmp_buf jmp; 3284 sys_jmp_buf jmp;
3212 EMACS_INT lisp_eval_depth; 3285 EMACS_INT f_lisp_eval_depth;
3213 ptrdiff_t pdlcount; 3286 ptrdiff_t pdlcount;
3214 int poll_suppress_count; 3287 int poll_suppress_count;
3215 int interrupt_input_blocked; 3288 int interrupt_input_blocked;
3289 struct byte_stack *byte_stack;
3216}; 3290};
3217 3291
3218extern Lisp_Object memory_signal_data; 3292extern Lisp_Object memory_signal_data;
3219 3293
3220/* An address near the bottom of the stack.
3221 Tells GC how to save a copy of the stack. */
3222extern char *stack_bottom;
3223
3224/* Check quit-flag and quit if it is non-nil. 3294/* Check quit-flag and quit if it is non-nil.
3225 Typing C-g does not directly cause a quit; it only sets Vquit_flag. 3295 Typing C-g does not directly cause a quit; it only sets Vquit_flag.
3226 So the program needs to do QUIT at times when it is safe to quit. 3296 So the program needs to do QUIT at times when it is safe to quit.
@@ -3622,9 +3692,10 @@ extern void refill_memory_reserve (void);
3622#endif 3692#endif
3623extern void alloc_unexec_pre (void); 3693extern void alloc_unexec_pre (void);
3624extern void alloc_unexec_post (void); 3694extern void alloc_unexec_post (void);
3695extern void mark_stack (char *, char *);
3696extern void flush_stack_call_func (void (*func) (void *arg), void *arg);
3625extern const char *pending_malloc_warning; 3697extern const char *pending_malloc_warning;
3626extern Lisp_Object zero_vector; 3698extern Lisp_Object zero_vector;
3627extern Lisp_Object *stack_base;
3628extern EMACS_INT consing_since_gc; 3699extern EMACS_INT consing_since_gc;
3629extern EMACS_INT gc_relative_threshold; 3700extern EMACS_INT gc_relative_threshold;
3630extern EMACS_INT memory_full_cons_threshold; 3701extern EMACS_INT memory_full_cons_threshold;
@@ -3886,7 +3957,6 @@ extern Lisp_Object Vautoload_queue;
3886extern Lisp_Object Vrun_hooks; 3957extern Lisp_Object Vrun_hooks;
3887extern Lisp_Object Vsignaling_function; 3958extern Lisp_Object Vsignaling_function;
3888extern Lisp_Object inhibit_lisp_code; 3959extern Lisp_Object inhibit_lisp_code;
3889extern struct handler *handlerlist;
3890 3960
3891/* To run a normal hook, use the appropriate function from the list below. 3961/* To run a normal hook, use the appropriate function from the list below.
3892 The calling convention: 3962 The calling convention:
@@ -3943,6 +4013,8 @@ extern void clear_unwind_protect (ptrdiff_t);
3943extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object); 4013extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object);
3944extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *); 4014extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *);
3945extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object); 4015extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object);
4016extern void rebind_for_thread_switch (void);
4017extern void unbind_for_thread_switch (struct thread_state *);
3946extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); 4018extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
3947extern _Noreturn void verror (const char *, va_list) 4019extern _Noreturn void verror (const char *, va_list)
3948 ATTRIBUTE_FORMAT_PRINTF (1, 0); 4020 ATTRIBUTE_FORMAT_PRINTF (1, 0);
@@ -3959,7 +4031,7 @@ extern void init_eval (void);
3959extern void syms_of_eval (void); 4031extern void syms_of_eval (void);
3960extern void unwind_body (Lisp_Object); 4032extern void unwind_body (Lisp_Object);
3961extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t); 4033extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t);
3962extern void mark_specpdl (void); 4034extern void mark_specpdl (union specbinding *first, union specbinding *ptr);
3963extern void get_backtrace (Lisp_Object array); 4035extern void get_backtrace (Lisp_Object array);
3964Lisp_Object backtrace_top_function (void); 4036Lisp_Object backtrace_top_function (void);
3965extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol); 4037extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
@@ -3974,6 +4046,9 @@ extern void module_init (void);
3974extern void syms_of_module (void); 4046extern void syms_of_module (void);
3975#endif 4047#endif
3976 4048
4049/* Defined in thread.c. */
4050extern void mark_threads (void);
4051
3977/* Defined in editfns.c. */ 4052/* Defined in editfns.c. */
3978extern void insert1 (Lisp_Object); 4053extern void insert1 (Lisp_Object);
3979extern Lisp_Object save_excursion_save (void); 4054extern Lisp_Object save_excursion_save (void);
@@ -4252,6 +4327,8 @@ extern int read_bytecode_char (bool);
4252 4327
4253/* Defined in bytecode.c. */ 4328/* Defined in bytecode.c. */
4254extern void syms_of_bytecode (void); 4329extern void syms_of_bytecode (void);
4330extern void relocate_byte_stack (struct byte_stack *);
4331extern struct byte_stack *byte_stack_list;
4255extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, 4332extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object,
4256 Lisp_Object, ptrdiff_t, Lisp_Object *); 4333 Lisp_Object, ptrdiff_t, Lisp_Object *);
4257extern Lisp_Object get_byte_code_arity (Lisp_Object); 4334extern 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 49340b120ef..e538c86fcf5 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 struct timespec *, 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,23 @@ 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 fd_callback_info[fd].flags |= FOR_READ;
458 if (fd > max_desc)
459 max_desc = fd;
460}
461
462static void
463add_process_read_fd (int fd)
464{
465 add_non_keyboard_read_fd (fd);
466 fd_callback_info[fd].flags |= PROCESS_FD;
450} 467}
451 468
452/* Stop monitoring file descriptor FD for when read is possible. */ 469/* Stop monitoring file descriptor FD for when read is possible. */
@@ -456,8 +473,7 @@ delete_read_fd (int fd)
456{ 473{
457 delete_keyboard_wait_descriptor (fd); 474 delete_keyboard_wait_descriptor (fd);
458 475
459 fd_callback_info[fd].condition &= ~FOR_READ; 476 if (fd_callback_info[fd].flags == 0)
460 if (fd_callback_info[fd].condition == 0)
461 { 477 {
462 fd_callback_info[fd].func = 0; 478 fd_callback_info[fd].func = 0;
463 fd_callback_info[fd].data = 0; 479 fd_callback_info[fd].data = 0;
@@ -470,28 +486,38 @@ delete_read_fd (int fd)
470void 486void
471add_write_fd (int fd, fd_callback func, void *data) 487add_write_fd (int fd, fd_callback func, void *data)
472{ 488{
473 FD_SET (fd, &write_mask); 489 if (fd > max_desc)
474 if (fd > max_input_desc) 490 max_desc = fd;
475 max_input_desc = fd;
476 491
477 fd_callback_info[fd].func = func; 492 fd_callback_info[fd].func = func;
478 fd_callback_info[fd].data = data; 493 fd_callback_info[fd].data = data;
479 fd_callback_info[fd].condition |= FOR_WRITE; 494 fd_callback_info[fd].flags |= FOR_WRITE;
480} 495}
481 496
482/* FD is no longer an input descriptor; update max_input_desc accordingly. */ 497static void
498add_non_blocking_write_fd (int fd)
499{
500 eassert (fd >= 0 && fd < FD_SETSIZE);
501 eassert (fd_callback_info[fd].func == NULL);
502
503 fd_callback_info[fd].flags |= FOR_WRITE | NON_BLOCKING_CONNECT_FD;
504 if (fd > max_desc)
505 max_desc = fd;
506 ++num_pending_connects;
507}
483 508
484static void 509static void
485delete_input_desc (int fd) 510recompute_max_desc (void)
486{ 511{
487 if (fd == max_input_desc) 512 int fd;
488 {
489 do
490 fd--;
491 while (0 <= fd && ! (FD_ISSET (fd, &input_wait_mask)
492 || FD_ISSET (fd, &write_mask)));
493 513
494 max_input_desc = fd; 514 for (fd = max_desc; fd >= 0; --fd)
515 {
516 if (fd_callback_info[fd].flags != 0)
517 {
518 max_desc = fd;
519 break;
520 }
495 } 521 }
496} 522}
497 523
@@ -500,13 +526,123 @@ delete_input_desc (int fd)
500void 526void
501delete_write_fd (int fd) 527delete_write_fd (int fd)
502{ 528{
503 FD_CLR (fd, &write_mask); 529 int lim = max_desc;
504 fd_callback_info[fd].condition &= ~FOR_WRITE; 530
505 if (fd_callback_info[fd].condition == 0) 531 if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0)
532 {
533 if (--num_pending_connects < 0)
534 emacs_abort ();
535 }
536 fd_callback_info[fd].flags &= ~(FOR_WRITE | NON_BLOCKING_CONNECT_FD);
537 if (fd_callback_info[fd].flags == 0)
506 { 538 {
507 fd_callback_info[fd].func = 0; 539 fd_callback_info[fd].func = 0;
508 fd_callback_info[fd].data = 0; 540 fd_callback_info[fd].data = 0;
509 delete_input_desc (fd); 541
542 if (fd == max_desc)
543 recompute_max_desc ();
544 }
545}
546
547static void
548compute_input_wait_mask (fd_set *mask)
549{
550 int fd;
551
552 FD_ZERO (mask);
553 for (fd = 0; fd <= max_desc; ++fd)
554 {
555 if (fd_callback_info[fd].thread != NULL
556 && fd_callback_info[fd].thread != current_thread)
557 continue;
558 if (fd_callback_info[fd].waiting_thread != NULL
559 && fd_callback_info[fd].waiting_thread != current_thread)
560 continue;
561 if ((fd_callback_info[fd].flags & FOR_READ) != 0)
562 {
563 FD_SET (fd, mask);
564 fd_callback_info[fd].waiting_thread = current_thread;
565 }
566 }
567}
568
569static void
570compute_non_process_wait_mask (fd_set *mask)
571{
572 int fd;
573
574 FD_ZERO (mask);
575 for (fd = 0; fd <= max_desc; ++fd)
576 {
577 if (fd_callback_info[fd].thread != NULL
578 && fd_callback_info[fd].thread != current_thread)
579 continue;
580 if (fd_callback_info[fd].waiting_thread != NULL
581 && fd_callback_info[fd].waiting_thread != current_thread)
582 continue;
583 if ((fd_callback_info[fd].flags & FOR_READ) != 0
584 && (fd_callback_info[fd].flags & PROCESS_FD) == 0)
585 {
586 FD_SET (fd, mask);
587 fd_callback_info[fd].waiting_thread = current_thread;
588 }
589 }
590}
591
592static void
593compute_non_keyboard_wait_mask (fd_set *mask)
594{
595 int fd;
596
597 FD_ZERO (mask);
598 for (fd = 0; fd <= max_desc; ++fd)
599 {
600 if (fd_callback_info[fd].thread != NULL
601 && fd_callback_info[fd].thread != current_thread)
602 continue;
603 if (fd_callback_info[fd].waiting_thread != NULL
604 && fd_callback_info[fd].waiting_thread != current_thread)
605 continue;
606 if ((fd_callback_info[fd].flags & FOR_READ) != 0
607 && (fd_callback_info[fd].flags & KEYBOARD_FD) == 0)
608 {
609 FD_SET (fd, mask);
610 fd_callback_info[fd].waiting_thread = current_thread;
611 }
612 }
613}
614
615static void
616compute_write_mask (fd_set *mask)
617{
618 int fd;
619
620 FD_ZERO (mask);
621 for (fd = 0; fd <= max_desc; ++fd)
622 {
623 if (fd_callback_info[fd].thread != NULL
624 && fd_callback_info[fd].thread != current_thread)
625 continue;
626 if (fd_callback_info[fd].waiting_thread != NULL
627 && fd_callback_info[fd].waiting_thread != current_thread)
628 continue;
629 if ((fd_callback_info[fd].flags & FOR_WRITE) != 0)
630 {
631 FD_SET (fd, mask);
632 fd_callback_info[fd].waiting_thread = current_thread;
633 }
634 }
635}
636
637static void
638clear_waiting_thread_info (void)
639{
640 int fd;
641
642 for (fd = 0; fd <= max_desc; ++fd)
643 {
644 if (fd_callback_info[fd].waiting_thread == current_thread)
645 fd_callback_info[fd].waiting_thread = NULL;
510 } 646 }
511} 647}
512 648
@@ -720,6 +856,7 @@ make_process (Lisp_Object name)
720 Lisp data to nil, so do it only for slots which should not be nil. */ 856 Lisp data to nil, so do it only for slots which should not be nil. */
721 pset_status (p, Qrun); 857 pset_status (p, Qrun);
722 pset_mark (p, Fmake_marker ()); 858 pset_mark (p, Fmake_marker ());
859 pset_thread (p, Fcurrent_thread ());
723 860
724 /* Initialize non-Lisp data. Note that allocate_process zeroes out all 861 /* Initialize non-Lisp data. Note that allocate_process zeroes out all
725 non-Lisp data, so do it only for slots which should not be zero. */ 862 non-Lisp data, so do it only for slots which should not be zero. */
@@ -768,6 +905,27 @@ remove_process (register Lisp_Object proc)
768 deactivate_process (proc); 905 deactivate_process (proc);
769} 906}
770 907
908void
909update_processes_for_thread_death (Lisp_Object dying_thread)
910{
911 Lisp_Object pair;
912
913 for (pair = Vprocess_alist; !NILP (pair); pair = XCDR (pair))
914 {
915 Lisp_Object process = XCDR (XCAR (pair));
916 if (EQ (XPROCESS (process)->thread, dying_thread))
917 {
918 struct Lisp_Process *proc = XPROCESS (process);
919
920 proc->thread = Qnil;
921 if (proc->infd >= 0)
922 fd_callback_info[proc->infd].thread = NULL;
923 if (proc->outfd >= 0)
924 fd_callback_info[proc->outfd].thread = NULL;
925 }
926 }
927}
928
771#ifdef HAVE_GETADDRINFO_A 929#ifdef HAVE_GETADDRINFO_A
772static void 930static void
773free_dns_request (Lisp_Object proc) 931free_dns_request (Lisp_Object proc)
@@ -1070,17 +1228,11 @@ static void
1070set_process_filter_masks (struct Lisp_Process *p) 1228set_process_filter_masks (struct Lisp_Process *p)
1071{ 1229{
1072 if (EQ (p->filter, Qt) && !EQ (p->status, Qlisten)) 1230 if (EQ (p->filter, Qt) && !EQ (p->status, Qlisten))
1073 { 1231 delete_read_fd (p->infd);
1074 FD_CLR (p->infd, &input_wait_mask);
1075 FD_CLR (p->infd, &non_keyboard_wait_mask);
1076 }
1077 else if (EQ (p->filter, Qt) 1232 else if (EQ (p->filter, Qt)
1078 /* Network or serial process not stopped: */ 1233 /* Network or serial process not stopped: */
1079 && !EQ (p->command, Qt)) 1234 && !EQ (p->command, Qt))
1080 { 1235 add_read_fd (p->infd);
1081 FD_SET (p->infd, &input_wait_mask);
1082 FD_SET (p->infd, &non_keyboard_wait_mask);
1083 }
1084} 1236}
1085 1237
1086DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter, 1238DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter,
@@ -1167,6 +1319,42 @@ See `set-process-sentinel' for more info on sentinels. */)
1167 return XPROCESS (process)->sentinel; 1319 return XPROCESS (process)->sentinel;
1168} 1320}
1169 1321
1322DEFUN ("set-process-thread", Fset_process_thread, Sset_process_thread,
1323 2, 2, 0,
1324 doc: /* FIXME */)
1325 (Lisp_Object process, Lisp_Object thread)
1326{
1327 struct Lisp_Process *proc;
1328 struct thread_state *tstate;
1329
1330 CHECK_PROCESS (process);
1331 if (NILP (thread))
1332 tstate = NULL;
1333 else
1334 {
1335 CHECK_THREAD (thread);
1336 tstate = XTHREAD (thread);
1337 }
1338
1339 proc = XPROCESS (process);
1340 proc->thread = thread;
1341 if (proc->infd >= 0)
1342 fd_callback_info[proc->infd].thread = tstate;
1343 if (proc->outfd >= 0)
1344 fd_callback_info[proc->outfd].thread = tstate;
1345
1346 return thread;
1347}
1348
1349DEFUN ("process-thread", Fprocess_thread, Sprocess_thread,
1350 1, 1, 0,
1351 doc: /* FIXME */)
1352 (Lisp_Object process)
1353{
1354 CHECK_PROCESS (process);
1355 return XPROCESS (process)->thread;
1356}
1357
1170DEFUN ("set-process-window-size", Fset_process_window_size, 1358DEFUN ("set-process-window-size", Fset_process_window_size,
1171 Sset_process_window_size, 3, 3, 0, 1359 Sset_process_window_size, 3, 3, 0,
1172 doc: /* Tell PROCESS that it has logical window size WIDTH by HEIGHT. 1360 doc: /* Tell PROCESS that it has logical window size WIDTH by HEIGHT.
@@ -1843,14 +2031,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
1843 p->pty_flag = pty_flag; 2031 p->pty_flag = pty_flag;
1844 pset_status (p, Qrun); 2032 pset_status (p, Qrun);
1845 2033
1846 if (!EQ (p->command, Qt)) 2034 add_process_read_fd (inchannel);
1847 {
1848 FD_SET (inchannel, &input_wait_mask);
1849 FD_SET (inchannel, &non_keyboard_wait_mask);
1850 }
1851
1852 if (inchannel > max_process_desc)
1853 max_process_desc = inchannel;
1854 2035
1855 /* This may signal an error. */ 2036 /* This may signal an error. */
1856 setup_process_coding_systems (process); 2037 setup_process_coding_systems (process);
@@ -2084,10 +2265,7 @@ create_pty (Lisp_Object process)
2084 pset_status (p, Qrun); 2265 pset_status (p, Qrun);
2085 setup_process_coding_systems (process); 2266 setup_process_coding_systems (process);
2086 2267
2087 FD_SET (pty_fd, &input_wait_mask); 2268 add_non_keyboard_read_fd (pty_fd);
2088 FD_SET (pty_fd, &non_keyboard_wait_mask);
2089 if (pty_fd > max_process_desc)
2090 max_process_desc = pty_fd;
2091 2269
2092 pset_tty_name (p, build_string (pty_name)); 2270 pset_tty_name (p, build_string (pty_name));
2093 } 2271 }
@@ -2171,8 +2349,8 @@ usage: (make-pipe-process &rest ARGS) */)
2171 p->infd = inchannel; 2349 p->infd = inchannel;
2172 p->outfd = outchannel; 2350 p->outfd = outchannel;
2173 2351
2174 if (inchannel > max_process_desc) 2352 if (inchannel > max_desc)
2175 max_process_desc = inchannel; 2353 max_desc = inchannel;
2176 2354
2177 buffer = Fplist_get (contact, QCbuffer); 2355 buffer = Fplist_get (contact, QCbuffer);
2178 if (NILP (buffer)) 2356 if (NILP (buffer))
@@ -2193,10 +2371,7 @@ usage: (make-pipe-process &rest ARGS) */)
2193 eassert (! p->pty_flag); 2371 eassert (! p->pty_flag);
2194 2372
2195 if (!EQ (p->command, Qt)) 2373 if (!EQ (p->command, Qt))
2196 { 2374 add_non_keyboard_read_fd (inchannel);
2197 FD_SET (inchannel, &input_wait_mask);
2198 FD_SET (inchannel, &non_keyboard_wait_mask);
2199 }
2200 p->adaptive_read_buffering 2375 p->adaptive_read_buffering
2201 = (NILP (Vprocess_adaptive_read_buffering) ? 0 2376 = (NILP (Vprocess_adaptive_read_buffering) ? 0
2202 : EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2); 2377 : EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2);
@@ -2909,8 +3084,8 @@ usage: (make-serial-process &rest ARGS) */)
2909 p->open_fd[SUBPROCESS_STDIN] = fd; 3084 p->open_fd[SUBPROCESS_STDIN] = fd;
2910 p->infd = fd; 3085 p->infd = fd;
2911 p->outfd = fd; 3086 p->outfd = fd;
2912 if (fd > max_process_desc) 3087 if (fd > max_desc)
2913 max_process_desc = fd; 3088 max_desc = fd;
2914 chan_process[fd] = proc; 3089 chan_process[fd] = proc;
2915 3090
2916 buffer = Fplist_get (contact, QCbuffer); 3091 buffer = Fplist_get (contact, QCbuffer);
@@ -2932,10 +3107,7 @@ usage: (make-serial-process &rest ARGS) */)
2932 eassert (! p->pty_flag); 3107 eassert (! p->pty_flag);
2933 3108
2934 if (!EQ (p->command, Qt)) 3109 if (!EQ (p->command, Qt))
2935 { 3110 add_non_keyboard_read_fd (fd);
2936 FD_SET (fd, &input_wait_mask);
2937 FD_SET (fd, &non_keyboard_wait_mask);
2938 }
2939 3111
2940 if (BUFFERP (buffer)) 3112 if (BUFFERP (buffer))
2941 { 3113 {
@@ -3417,25 +3589,18 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
3417 if (! (connecting_status (p->status) 3589 if (! (connecting_status (p->status)
3418 && EQ (XCDR (p->status), addrinfos))) 3590 && EQ (XCDR (p->status), addrinfos)))
3419 pset_status (p, Fcons (Qconnect, addrinfos)); 3591 pset_status (p, Fcons (Qconnect, addrinfos));
3420 if (!FD_ISSET (inch, &connect_wait_mask)) 3592 if ((fd_callback_info[inch].flags & NON_BLOCKING_CONNECT_FD) == 0)
3421 { 3593 add_non_blocking_write_fd (inch);
3422 FD_SET (inch, &connect_wait_mask);
3423 FD_SET (inch, &write_mask);
3424 num_pending_connects++;
3425 }
3426 } 3594 }
3427 else 3595 else
3428 /* A server may have a client filter setting of Qt, but it must 3596 /* A server may have a client filter setting of Qt, but it must
3429 still listen for incoming connects unless it is stopped. */ 3597 still listen for incoming connects unless it is stopped. */
3430 if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt)) 3598 if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt))
3431 || (EQ (p->status, Qlisten) && NILP (p->command))) 3599 || (EQ (p->status, Qlisten) && NILP (p->command)))
3432 { 3600 add_non_keyboard_read_fd (inch);
3433 FD_SET (inch, &input_wait_mask);
3434 FD_SET (inch, &non_keyboard_wait_mask);
3435 }
3436 3601
3437 if (inch > max_process_desc) 3602 if (inch > max_desc)
3438 max_process_desc = inch; 3603 max_desc = inch;
3439 3604
3440 /* Set up the masks based on the process filter. */ 3605 /* Set up the masks based on the process filter. */
3441 set_process_filter_masks (p); 3606 set_process_filter_masks (p);
@@ -4366,26 +4531,11 @@ deactivate_process (Lisp_Object proc)
4366 } 4531 }
4367#endif 4532#endif
4368 chan_process[inchannel] = Qnil; 4533 chan_process[inchannel] = Qnil;
4369 FD_CLR (inchannel, &input_wait_mask); 4534 delete_read_fd (inchannel);
4370 FD_CLR (inchannel, &non_keyboard_wait_mask); 4535 if ((fd_callback_info[inchannel].flags & NON_BLOCKING_CONNECT_FD) != 0)
4371 if (FD_ISSET (inchannel, &connect_wait_mask)) 4536 delete_write_fd (inchannel);
4372 { 4537 if (inchannel == max_desc)
4373 FD_CLR (inchannel, &connect_wait_mask); 4538 recompute_max_desc ();
4374 FD_CLR (inchannel, &write_mask);
4375 if (--num_pending_connects < 0)
4376 emacs_abort ();
4377 }
4378 if (inchannel == max_process_desc)
4379 {
4380 /* We just closed the highest-numbered process input descriptor,
4381 so recompute the highest-numbered one now. */
4382 int i = inchannel;
4383 do
4384 i--;
4385 while (0 <= i && NILP (chan_process[i]));
4386
4387 max_process_desc = i;
4388 }
4389 } 4539 }
4390} 4540}
4391 4541
@@ -4414,7 +4564,17 @@ is nil, from any process) before the timeout expired. */)
4414 int nsecs; 4564 int nsecs;
4415 4565
4416 if (! NILP (process)) 4566 if (! NILP (process))
4417 CHECK_PROCESS (process); 4567 {
4568 struct Lisp_Process *procp;
4569
4570 CHECK_PROCESS (process);
4571 procp = XPROCESS (process);
4572
4573 /* Can't wait for a process that is dedicated to a different
4574 thread. */
4575 if (!EQ (procp->thread, Qnil) && !EQ (procp->thread, Fcurrent_thread ()))
4576 error ("FIXME");
4577 }
4418 else 4578 else
4419 just_this_one = Qnil; 4579 just_this_one = Qnil;
4420 4580
@@ -4632,13 +4792,7 @@ server_accept_connection (Lisp_Object server, int channel)
4632 4792
4633 /* Client processes for accepted connections are not stopped initially. */ 4793 /* Client processes for accepted connections are not stopped initially. */
4634 if (!EQ (p->filter, Qt)) 4794 if (!EQ (p->filter, Qt))
4635 { 4795 add_non_keyboard_read_fd (s);
4636 FD_SET (s, &input_wait_mask);
4637 FD_SET (s, &non_keyboard_wait_mask);
4638 }
4639
4640 if (s > max_process_desc)
4641 max_process_desc = s;
4642 4796
4643 /* Setup coding system for new process based on server process. 4797 /* Setup coding system for new process based on server process.
4644 This seems to be the proper thing to do, as the coding system 4798 This seems to be the proper thing to do, as the coding system
@@ -4751,20 +4905,10 @@ wait_for_tls_negotiation (Lisp_Object process)
4751#endif 4905#endif
4752} 4906}
4753 4907
4754/* This variable is different from waiting_for_input in keyboard.c.
4755 It is used to communicate to a lisp process-filter/sentinel (via the
4756 function Fwaiting_for_user_input_p below) whether Emacs was waiting
4757 for user-input when that process-filter was called.
4758 waiting_for_input cannot be used as that is by definition 0 when
4759 lisp code is being evalled.
4760 This is also used in record_asynch_buffer_change.
4761 For that purpose, this must be 0
4762 when not inside wait_reading_process_output. */
4763static int waiting_for_user_input_p;
4764
4765static void 4908static void
4766wait_reading_process_output_unwind (int data) 4909wait_reading_process_output_unwind (int data)
4767{ 4910{
4911 clear_waiting_thread_info ();
4768 waiting_for_user_input_p = data; 4912 waiting_for_user_input_p = data;
4769} 4913}
4770 4914
@@ -4837,6 +4981,10 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
4837 /* Close to the current time if known, an invalid timespec otherwise. */ 4981 /* Close to the current time if known, an invalid timespec otherwise. */
4838 struct timespec now = invalid_timespec (); 4982 struct timespec now = invalid_timespec ();
4839 4983
4984 eassert (wait_proc == NULL
4985 || EQ (wait_proc->thread, Qnil)
4986 || XTHREAD (wait_proc->thread) == current_thread);
4987
4840 FD_ZERO (&Available); 4988 FD_ZERO (&Available);
4841 FD_ZERO (&Writeok); 4989 FD_ZERO (&Writeok);
4842 4990
@@ -5009,14 +5157,14 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5009 if (kbd_on_hold_p ()) 5157 if (kbd_on_hold_p ())
5010 FD_ZERO (&Atemp); 5158 FD_ZERO (&Atemp);
5011 else 5159 else
5012 Atemp = input_wait_mask; 5160 compute_input_wait_mask (&Atemp);
5013 Ctemp = write_mask; 5161 compute_write_mask (&Ctemp);
5014 5162
5015 timeout = make_timespec (0, 0); 5163 timeout = make_timespec (0, 0);
5016 if ((pselect (max (max_process_desc, max_input_desc) + 1, 5164 if ((thread_select (pselect, max_desc + 1,
5017 &Atemp, 5165 &Atemp,
5018 (num_pending_connects > 0 ? &Ctemp : NULL), 5166 (num_pending_connects > 0 ? &Ctemp : NULL),
5019 NULL, &timeout, NULL) 5167 NULL, &timeout, NULL)
5020 <= 0)) 5168 <= 0))
5021 { 5169 {
5022 /* It's okay for us to do this and then continue with 5170 /* It's okay for us to do this and then continue with
@@ -5081,17 +5229,17 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5081 } 5229 }
5082 else if (!NILP (wait_for_cell)) 5230 else if (!NILP (wait_for_cell))
5083 { 5231 {
5084 Available = non_process_wait_mask; 5232 compute_non_process_wait_mask (&Available);
5085 check_delay = 0; 5233 check_delay = 0;
5086 check_write = 0; 5234 check_write = 0;
5087 } 5235 }
5088 else 5236 else
5089 { 5237 {
5090 if (! read_kbd) 5238 if (! read_kbd)
5091 Available = non_keyboard_wait_mask; 5239 compute_non_keyboard_wait_mask (&Available);
5092 else 5240 else
5093 Available = input_wait_mask; 5241 compute_input_wait_mask (&Available);
5094 Writeok = write_mask; 5242 compute_write_mask (&Writeok);
5095 check_delay = wait_proc ? 0 : process_output_delay_count; 5243 check_delay = wait_proc ? 0 : process_output_delay_count;
5096 check_write = true; 5244 check_write = true;
5097 } 5245 }
@@ -5133,7 +5281,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5133 int adaptive_nsecs = timeout.tv_nsec; 5281 int adaptive_nsecs = timeout.tv_nsec;
5134 if (timeout.tv_sec > 0 || adaptive_nsecs > READ_OUTPUT_DELAY_MAX) 5282 if (timeout.tv_sec > 0 || adaptive_nsecs > READ_OUTPUT_DELAY_MAX)
5135 adaptive_nsecs = READ_OUTPUT_DELAY_MAX; 5283 adaptive_nsecs = READ_OUTPUT_DELAY_MAX;
5136 for (channel = 0; check_delay > 0 && channel <= max_process_desc; channel++) 5284 for (channel = 0; check_delay > 0 && channel <= max_desc; channel++)
5137 { 5285 {
5138 proc = chan_process[channel]; 5286 proc = chan_process[channel];
5139 if (NILP (proc)) 5287 if (NILP (proc))
@@ -5192,17 +5340,18 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5192 } 5340 }
5193#endif 5341#endif
5194 5342
5343 nfds = thread_select (
5195#if defined (HAVE_NS) 5344#if defined (HAVE_NS)
5196 nfds = ns_select 5345 ns_select
5197#elif defined (HAVE_GLIB) 5346#elif defined (HAVE_GLIB)
5198 nfds = xg_select 5347 xg_select
5199#else 5348#else
5200 nfds = pselect 5349 pselect
5201#endif 5350#endif
5202 (max (max_process_desc, max_input_desc) + 1, 5351 , max_desc + 1,
5203 &Available, 5352 &Available,
5204 (check_write ? &Writeok : 0), 5353 (check_write ? &Writeok : 0),
5205 NULL, &timeout, NULL); 5354 NULL, &timeout, NULL);
5206 5355
5207#ifdef HAVE_GNUTLS 5356#ifdef HAVE_GNUTLS
5208 /* GnuTLS buffers data internally. In lowat mode it leaves 5357 /* GnuTLS buffers data internally. In lowat mode it leaves
@@ -5386,22 +5535,22 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5386 if (no_avail || nfds == 0) 5535 if (no_avail || nfds == 0)
5387 continue; 5536 continue;
5388 5537
5389 for (channel = 0; channel <= max_input_desc; ++channel) 5538 for (channel = 0; channel <= max_desc; ++channel)
5390 { 5539 {
5391 struct fd_callback_data *d = &fd_callback_info[channel]; 5540 struct fd_callback_data *d = &fd_callback_info[channel];
5392 if (d->func 5541 if (d->func
5393 && ((d->condition & FOR_READ 5542 && ((d->flags & FOR_READ
5394 && FD_ISSET (channel, &Available)) 5543 && FD_ISSET (channel, &Available))
5395 || (d->condition & FOR_WRITE 5544 || (d->flags & FOR_WRITE
5396 && FD_ISSET (channel, &write_mask)))) 5545 && FD_ISSET (channel, &Writeok))))
5397 d->func (channel, d->data); 5546 d->func (channel, d->data);
5398 } 5547 }
5399 5548
5400 for (channel = 0; channel <= max_process_desc; channel++) 5549 for (channel = 0; channel <= max_desc; channel++)
5401 { 5550 {
5402 if (FD_ISSET (channel, &Available) 5551 if (FD_ISSET (channel, &Available)
5403 && FD_ISSET (channel, &non_keyboard_wait_mask) 5552 && ((fd_callback_info[channel].flags & (KEYBOARD_FD | PROCESS_FD))
5404 && !FD_ISSET (channel, &non_process_wait_mask)) 5553 == PROCESS_FD))
5405 { 5554 {
5406 int nread; 5555 int nread;
5407 5556
@@ -5466,8 +5615,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5466 5615
5467 /* Clear the descriptor now, so we only raise the 5616 /* Clear the descriptor now, so we only raise the
5468 signal once. */ 5617 signal once. */
5469 FD_CLR (channel, &input_wait_mask); 5618 delete_read_fd (channel);
5470 FD_CLR (channel, &non_keyboard_wait_mask);
5471 5619
5472 if (p->pid == -2) 5620 if (p->pid == -2)
5473 { 5621 {
@@ -5506,14 +5654,12 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5506 } 5654 }
5507 } 5655 }
5508 if (FD_ISSET (channel, &Writeok) 5656 if (FD_ISSET (channel, &Writeok)
5509 && FD_ISSET (channel, &connect_wait_mask)) 5657 && (fd_callback_info[channel].flags
5658 & NON_BLOCKING_CONNECT_FD) != 0)
5510 { 5659 {
5511 struct Lisp_Process *p; 5660 struct Lisp_Process *p;
5512 5661
5513 FD_CLR (channel, &connect_wait_mask); 5662 delete_write_fd (channel);
5514 FD_CLR (channel, &write_mask);
5515 if (--num_pending_connects < 0)
5516 emacs_abort ();
5517 5663
5518 proc = chan_process[channel]; 5664 proc = chan_process[channel];
5519 if (NILP (proc)) 5665 if (NILP (proc))
@@ -5581,10 +5727,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5581 5727
5582 if (0 <= p->infd && !EQ (p->filter, Qt) 5728 if (0 <= p->infd && !EQ (p->filter, Qt)
5583 && !EQ (p->command, Qt)) 5729 && !EQ (p->command, Qt))
5584 { 5730 delete_read_fd (p->infd);
5585 FD_SET (p->infd, &input_wait_mask);
5586 FD_SET (p->infd, &non_keyboard_wait_mask);
5587 }
5588 } 5731 }
5589 } 5732 }
5590 } /* End for each file descriptor. */ 5733 } /* End for each file descriptor. */
@@ -6555,10 +6698,7 @@ of incoming traffic. */)
6555 p = XPROCESS (process); 6698 p = XPROCESS (process);
6556 if (NILP (p->command) 6699 if (NILP (p->command)
6557 && p->infd >= 0) 6700 && p->infd >= 0)
6558 { 6701 delete_read_fd (p->infd);
6559 FD_CLR (p->infd, &input_wait_mask);
6560 FD_CLR (p->infd, &non_keyboard_wait_mask);
6561 }
6562 pset_command (p, Qt); 6702 pset_command (p, Qt);
6563 return process; 6703 return process;
6564 } 6704 }
@@ -6587,8 +6727,7 @@ traffic. */)
6587 && p->infd >= 0 6727 && p->infd >= 0
6588 && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten))) 6728 && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten)))
6589 { 6729 {
6590 FD_SET (p->infd, &input_wait_mask); 6730 add_non_keyboard_read_fd (p->infd);
6591 FD_SET (p->infd, &non_keyboard_wait_mask);
6592#ifdef WINDOWSNT 6731#ifdef WINDOWSNT
6593 if (fd_info[ p->infd ].flags & FILE_SERIAL) 6732 if (fd_info[ p->infd ].flags & FILE_SERIAL)
6594 PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR); 6733 PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR);
@@ -6895,10 +7034,7 @@ handle_child_signal (int sig)
6895 7034
6896 /* clear_desc_flag avoids a compiler bug in Microsoft C. */ 7035 /* clear_desc_flag avoids a compiler bug in Microsoft C. */
6897 if (clear_desc_flag) 7036 if (clear_desc_flag)
6898 { 7037 delete_read_fd (p->infd);
6899 FD_CLR (p->infd, &input_wait_mask);
6900 FD_CLR (p->infd, &non_keyboard_wait_mask);
6901 }
6902 } 7038 }
6903 } 7039 }
6904 } 7040 }
@@ -7258,9 +7394,9 @@ keyboard_bit_set (fd_set *mask)
7258{ 7394{
7259 int fd; 7395 int fd;
7260 7396
7261 for (fd = 0; fd <= max_input_desc; fd++) 7397 for (fd = 0; fd <= max_desc; fd++)
7262 if (FD_ISSET (fd, mask) && FD_ISSET (fd, &input_wait_mask) 7398 if (FD_ISSET (fd, mask)
7263 && !FD_ISSET (fd, &non_keyboard_wait_mask)) 7399 && ((fd_callback_info[fd].flags & KEYBOARD_FD) != 0))
7264 return 1; 7400 return 1;
7265 7401
7266 return 0; 7402 return 0;
@@ -7497,14 +7633,9 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
7497void 7633void
7498add_timer_wait_descriptor (int fd) 7634add_timer_wait_descriptor (int fd)
7499{ 7635{
7500 FD_SET (fd, &input_wait_mask); 7636 add_read_fd (fd, timerfd_callback, NULL);
7501 FD_SET (fd, &non_keyboard_wait_mask); 7637 if (fd > max_desc)
7502 FD_SET (fd, &non_process_wait_mask); 7638 max_desc = fd;
7503 fd_callback_info[fd].func = timerfd_callback;
7504 fd_callback_info[fd].data = NULL;
7505 fd_callback_info[fd].condition |= FOR_READ;
7506 if (fd > max_input_desc)
7507 max_input_desc = fd;
7508} 7639}
7509 7640
7510#endif /* HAVE_TIMERFD */ 7641#endif /* HAVE_TIMERFD */
@@ -7528,10 +7659,10 @@ void
7528add_keyboard_wait_descriptor (int desc) 7659add_keyboard_wait_descriptor (int desc)
7529{ 7660{
7530#ifdef subprocesses /* Actually means "not MSDOS". */ 7661#ifdef subprocesses /* Actually means "not MSDOS". */
7531 FD_SET (desc, &input_wait_mask); 7662 eassert (desc >= 0 && desc < FD_SETSIZE);
7532 FD_SET (desc, &non_process_wait_mask); 7663 fd_callback_info[desc].flags |= FOR_READ | KEYBOARD_FD;
7533 if (desc > max_input_desc) 7664 if (desc > max_desc)
7534 max_input_desc = desc; 7665 max_desc = desc;
7535#endif 7666#endif
7536} 7667}
7537 7668
@@ -7541,9 +7672,15 @@ void
7541delete_keyboard_wait_descriptor (int desc) 7672delete_keyboard_wait_descriptor (int desc)
7542{ 7673{
7543#ifdef subprocesses 7674#ifdef subprocesses
7544 FD_CLR (desc, &input_wait_mask); 7675 int fd;
7545 FD_CLR (desc, &non_process_wait_mask); 7676 int lim = max_desc;
7546 delete_input_desc (desc); 7677
7678 eassert (desc >= 0 && desc < FD_SETSIZE);
7679
7680 fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD);
7681
7682 if (desc == max_desc)
7683 recompute_max_desc ();
7547#endif 7684#endif
7548} 7685}
7549 7686
@@ -7824,15 +7961,10 @@ init_process_emacs (int sockfd)
7824 } 7961 }
7825#endif 7962#endif
7826 7963
7827 FD_ZERO (&input_wait_mask);
7828 FD_ZERO (&non_keyboard_wait_mask);
7829 FD_ZERO (&non_process_wait_mask);
7830 FD_ZERO (&write_mask);
7831 max_process_desc = max_input_desc = -1;
7832 external_sock_fd = sockfd; 7964 external_sock_fd = sockfd;
7965 max_desc = -1;
7833 memset (fd_callback_info, 0, sizeof (fd_callback_info)); 7966 memset (fd_callback_info, 0, sizeof (fd_callback_info));
7834 7967
7835 FD_ZERO (&connect_wait_mask);
7836 num_pending_connects = 0; 7968 num_pending_connects = 0;
7837 7969
7838 process_output_delay_count = 0; 7970 process_output_delay_count = 0;
@@ -8032,6 +8164,8 @@ The variable takes effect when `start-process' is called. */);
8032 defsubr (&Sprocess_filter); 8164 defsubr (&Sprocess_filter);
8033 defsubr (&Sset_process_sentinel); 8165 defsubr (&Sset_process_sentinel);
8034 defsubr (&Sprocess_sentinel); 8166 defsubr (&Sprocess_sentinel);
8167 defsubr (&Sset_process_thread);
8168 defsubr (&Sprocess_thread);
8035 defsubr (&Sset_process_window_size); 8169 defsubr (&Sset_process_window_size);
8036 defsubr (&Sset_process_inherit_coding_system_flag); 8170 defsubr (&Sset_process_inherit_coding_system_flag);
8037 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..bb046858dfe 100644
--- a/src/regex.c
+++ b/src/regex.c
@@ -1140,13 +1140,13 @@ print_double_string (re_char *where, re_char *string1, ssize_t size1,
1140#endif /* not DEBUG */ 1140#endif /* not DEBUG */
1141 1141
1142#ifndef emacs 1142#ifndef emacs
1143
1144/* Set by `re_set_syntax' to the current regexp syntax to recognize. Can 1143/* Set by `re_set_syntax' to the current regexp syntax to recognize. Can
1145 also be assigned to arbitrarily: each pattern buffer stores its own 1144 also be assigned to arbitrarily: each pattern buffer stores its own
1146 syntax, so it can be changed between regex compilations. */ 1145 syntax, so it can be changed between regex compilations. */
1147/* This has no initializer because initialized variables in Emacs 1146/* This has no initializer because initialized variables in Emacs
1148 become read-only after dumping. */ 1147 become read-only after dumping. */
1149reg_syntax_t re_syntax_options; 1148reg_syntax_t re_syntax_options;
1149#endif
1150 1150
1151 1151
1152/* Specify the precise syntax of regexps for compilation. This provides 1152/* Specify the precise syntax of regexps for compilation. This provides
@@ -1166,7 +1166,20 @@ re_set_syntax (reg_syntax_t syntax)
1166} 1166}
1167WEAK_ALIAS (__re_set_syntax, re_set_syntax) 1167WEAK_ALIAS (__re_set_syntax, re_set_syntax)
1168 1168
1169#ifndef emacs
1170/* Regexp to use to replace spaces, or NULL meaning don't. */
1171static const_re_char *whitespace_regexp;
1172#else
1173/* whitespace_regexp is a macro defined in thread.h. */
1169#endif 1174#endif
1175
1176void
1177re_set_whitespace_regexp (const char *regexp)
1178{
1179 whitespace_regexp = (const_re_char *) regexp;
1180}
1181WEAK_ALIAS (__re_set_syntax, re_set_syntax)
1182>>>>>>> concurrency
1170 1183
1171/* This table gives an error message for each of the error codes listed 1184/* This table gives an error message for each of the error codes listed
1172 in regex.h. Obviously the order here has to be same as there. 1185 in regex.h. Obviously the order here has to be same as there.
@@ -4885,12 +4898,6 @@ re_match (struct re_pattern_buffer *bufp, const char *string,
4885WEAK_ALIAS (__re_match, re_match) 4898WEAK_ALIAS (__re_match, re_match)
4886#endif /* not emacs */ 4899#endif /* not emacs */
4887 4900
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 4901/* re_match_2 matches the compiled pattern in BUFP against the
4895 the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1 4902 the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1
4896 and SIZE2, respectively). We start matching at POS, and stop 4903 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..edc3f05ab2b 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -51,13 +51,24 @@ 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
59#ifdef TRY_AGAIN
60#ifndef HAVE_H_ERRNO
61extern int h_errno;
62#endif
63#endif /* TRY_AGAIN */
64
54#ifdef WINDOWSNT 65#ifdef WINDOWSNT
55#define read sys_read 66#define read sys_read
56#define write sys_write 67#define write sys_write
57#ifndef STDERR_FILENO 68#ifndef STDERR_FILENO
58#define STDERR_FILENO fileno(GetStdHandle(STD_ERROR_HANDLE)) 69#define STDERR_FILENO fileno(GetStdHandle(STD_ERROR_HANDLE))
59#endif 70#endif
60#include <windows.h> 71#include "w32.h"
61#endif /* not WINDOWSNT */ 72#endif /* not WINDOWSNT */
62 73
63#include <sys/types.h> 74#include <sys/types.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..f5b04e4b231
--- /dev/null
+++ b/src/thread.c
@@ -0,0 +1,975 @@
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 struct thread_state *self = current_thread;
147
148 if (mutex->owner != current_thread)
149 error ("blah");
150
151 if (--mutex->count > 0)
152 return 0;
153
154 mutex->owner = NULL;
155 sys_cond_broadcast (&mutex->condition);
156
157 return 1;
158}
159
160static unsigned int
161lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex)
162{
163 struct thread_state *self = current_thread;
164 unsigned int result = mutex->count;
165
166 /* Ensured by condvar code. */
167 eassert (mutex->owner == current_thread);
168
169 mutex->count = 0;
170 mutex->owner = NULL;
171 sys_cond_broadcast (&mutex->condition);
172
173 return result;
174}
175
176static void
177lisp_mutex_destroy (lisp_mutex_t *mutex)
178{
179 sys_cond_destroy (&mutex->condition);
180}
181
182static int
183lisp_mutex_owned_p (lisp_mutex_t *mutex)
184{
185 return mutex->owner == current_thread;
186}
187
188
189
190DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
191 doc: /* Create a mutex.
192A mutex provides a synchronization point for threads.
193Only one thread at a time can hold a mutex. Other threads attempting
194to acquire it will block until the mutex is available.
195
196A thread can acquire a mutex any number of times.
197
198NAME, if given, is used as the name of the mutex. The name is
199informational only. */)
200 (Lisp_Object name)
201{
202 struct Lisp_Mutex *mutex;
203 Lisp_Object result;
204
205 if (!NILP (name))
206 CHECK_STRING (name);
207
208 mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
209 memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
210 0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
211 mutex));
212 mutex->name = name;
213 lisp_mutex_init (&mutex->mutex);
214
215 XSETMUTEX (result, mutex);
216 return result;
217}
218
219static void
220mutex_lock_callback (void *arg)
221{
222 struct Lisp_Mutex *mutex = arg;
223 struct thread_state *self = current_thread;
224
225 if (lisp_mutex_lock (&mutex->mutex, 0))
226 post_acquire_global_lock (self);
227}
228
229static void
230do_unwind_mutex_lock (void)
231{
232 current_thread->event_object = Qnil;
233}
234
235DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
236 doc: /* Acquire a mutex.
237If the current thread already owns MUTEX, increment the count and
238return.
239Otherwise, if no thread owns MUTEX, make the current thread own it.
240Otherwise, block until MUTEX is available, or until the current thread
241is signalled using `thread-signal'.
242Note that calls to `mutex-lock' and `mutex-unlock' must be paired. */)
243 (Lisp_Object mutex)
244{
245 struct Lisp_Mutex *lmutex;
246 ptrdiff_t count = SPECPDL_INDEX ();
247
248 CHECK_MUTEX (mutex);
249 lmutex = XMUTEX (mutex);
250
251 current_thread->event_object = mutex;
252 record_unwind_protect_void (do_unwind_mutex_lock);
253 flush_stack_call_func (mutex_lock_callback, lmutex);
254 return unbind_to (count, Qnil);
255}
256
257static void
258mutex_unlock_callback (void *arg)
259{
260 struct Lisp_Mutex *mutex = arg;
261 struct thread_state *self = current_thread;
262
263 if (lisp_mutex_unlock (&mutex->mutex))
264 post_acquire_global_lock (self);
265}
266
267DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
268 doc: /* Release the mutex.
269If this thread does not own MUTEX, signal an error.
270Otherwise, decrement the mutex's count. If the count is zero,
271release MUTEX. */)
272 (Lisp_Object mutex)
273{
274 struct Lisp_Mutex *lmutex;
275
276 CHECK_MUTEX (mutex);
277 lmutex = XMUTEX (mutex);
278
279 flush_stack_call_func (mutex_unlock_callback, lmutex);
280 return Qnil;
281}
282
283DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0,
284 doc: /* Return the name of MUTEX.
285If no name was given when MUTEX was created, return nil. */)
286 (Lisp_Object mutex)
287{
288 struct Lisp_Mutex *lmutex;
289
290 CHECK_MUTEX (mutex);
291 lmutex = XMUTEX (mutex);
292
293 return lmutex->name;
294}
295
296void
297finalize_one_mutex (struct Lisp_Mutex *mutex)
298{
299 lisp_mutex_destroy (&mutex->mutex);
300}
301
302
303
304DEFUN ("make-condition-variable",
305 Fmake_condition_variable, Smake_condition_variable,
306 1, 2, 0,
307 doc: /* Make a condition variable.
308A condition variable provides a way for a thread to sleep while
309waiting for a state change.
310
311MUTEX is the mutex associated with this condition variable.
312NAME, if given, is the name of this condition variable. The name is
313informational only. */)
314 (Lisp_Object mutex, Lisp_Object name)
315{
316 struct Lisp_CondVar *condvar;
317 Lisp_Object result;
318
319 CHECK_MUTEX (mutex);
320 if (!NILP (name))
321 CHECK_STRING (name);
322
323 condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
324 memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
325 0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
326 cond));
327 condvar->mutex = mutex;
328 condvar->name = name;
329 sys_cond_init (&condvar->cond);
330
331 XSETCONDVAR (result, condvar);
332 return result;
333}
334
335static void
336condition_wait_callback (void *arg)
337{
338 struct Lisp_CondVar *cvar = arg;
339 struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex);
340 struct thread_state *self = current_thread;
341 unsigned int saved_count;
342 Lisp_Object cond;
343
344 XSETCONDVAR (cond, cvar);
345 self->event_object = cond;
346 saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
347 /* If we were signalled while unlocking, we skip the wait, but we
348 still must reacquire our lock. */
349 if (NILP (self->error_symbol))
350 {
351 self->wait_condvar = &cvar->cond;
352 sys_cond_wait (&cvar->cond, &global_lock);
353 self->wait_condvar = NULL;
354 }
355 lisp_mutex_lock (&mutex->mutex, saved_count);
356 self->event_object = Qnil;
357 post_acquire_global_lock (self);
358}
359
360DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
361 doc: /* Wait for the condition variable to be notified.
362CONDITION is the condition variable to wait on.
363
364The mutex associated with CONDITION must be held when this is called.
365It is an error if it is not held.
366
367This releases the mutex and waits for CONDITION to be notified or for
368this thread to be signalled with `thread-signal'. When
369`condition-wait' returns, the mutex will again be locked by this
370thread. */)
371 (Lisp_Object condition)
372{
373 struct Lisp_CondVar *cvar;
374 struct Lisp_Mutex *mutex;
375
376 CHECK_CONDVAR (condition);
377 cvar = XCONDVAR (condition);
378
379 mutex = XMUTEX (cvar->mutex);
380 if (!lisp_mutex_owned_p (&mutex->mutex))
381 error ("fixme");
382
383 flush_stack_call_func (condition_wait_callback, cvar);
384
385 return Qnil;
386}
387
388/* Used to communicate argumnets to condition_notify_callback. */
389struct notify_args
390{
391 struct Lisp_CondVar *cvar;
392 int all;
393};
394
395static void
396condition_notify_callback (void *arg)
397{
398 struct notify_args *na = arg;
399 struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex);
400 struct thread_state *self = current_thread;
401 unsigned int saved_count;
402 Lisp_Object cond;
403
404 XSETCONDVAR (cond, na->cvar);
405 saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
406 if (na->all)
407 sys_cond_broadcast (&na->cvar->cond);
408 else
409 sys_cond_signal (&na->cvar->cond);
410 lisp_mutex_lock (&mutex->mutex, saved_count);
411 post_acquire_global_lock (self);
412}
413
414DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0,
415 doc: /* Notify a condition variable.
416This wakes a thread waiting on CONDITION.
417If ALL is non-nil, all waiting threads are awoken.
418
419The mutex associated with CONDITION must be held when this is called.
420It is an error if it is not held.
421
422This releases the mutex when notifying CONDITION. When
423`condition-notify' returns, the mutex will again be locked by this
424thread. */)
425 (Lisp_Object condition, Lisp_Object all)
426{
427 struct Lisp_CondVar *cvar;
428 struct Lisp_Mutex *mutex;
429 struct notify_args args;
430
431 CHECK_CONDVAR (condition);
432 cvar = XCONDVAR (condition);
433
434 mutex = XMUTEX (cvar->mutex);
435 if (!lisp_mutex_owned_p (&mutex->mutex))
436 error ("fixme");
437
438 args.cvar = cvar;
439 args.all = !NILP (all);
440 flush_stack_call_func (condition_notify_callback, &args);
441
442 return Qnil;
443}
444
445DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0,
446 doc: /* Return the mutex associated with CONDITION. */)
447 (Lisp_Object condition)
448{
449 struct Lisp_CondVar *cvar;
450
451 CHECK_CONDVAR (condition);
452 cvar = XCONDVAR (condition);
453
454 return cvar->mutex;
455}
456
457DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0,
458 doc: /* Return the name of CONDITION.
459If no name was given when CONDITION was created, return nil. */)
460 (Lisp_Object condition)
461{
462 struct Lisp_CondVar *cvar;
463
464 CHECK_CONDVAR (condition);
465 cvar = XCONDVAR (condition);
466
467 return cvar->name;
468}
469
470void
471finalize_one_condvar (struct Lisp_CondVar *condvar)
472{
473 sys_cond_destroy (&condvar->cond);
474}
475
476
477
478struct select_args
479{
480 select_func *func;
481 int max_fds;
482 fd_set *rfds;
483 fd_set *wfds;
484 fd_set *efds;
485 struct timespec *timeout;
486 sigset_t *sigmask;
487 int result;
488};
489
490static void
491really_call_select (void *arg)
492{
493 struct select_args *sa = arg;
494 struct thread_state *self = current_thread;
495
496 release_global_lock ();
497 sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
498 sa->timeout, sa->sigmask);
499 acquire_global_lock (self);
500}
501
502int
503thread_select (select_func *func, int max_fds, fd_set *rfds,
504 fd_set *wfds, fd_set *efds, struct timespec *timeout,
505 sigset_t *sigmask)
506{
507 struct select_args sa;
508
509 sa.func = func;
510 sa.max_fds = max_fds;
511 sa.rfds = rfds;
512 sa.wfds = wfds;
513 sa.efds = efds;
514 sa.timeout = timeout;
515 sa.sigmask = sigmask;
516 flush_stack_call_func (really_call_select, &sa);
517 return sa.result;
518}
519
520
521
522static void
523mark_one_thread (struct thread_state *thread)
524{
525 struct handler *handler;
526 Lisp_Object tem;
527
528 mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
529
530 mark_stack (thread->m_stack_bottom, thread->stack_top);
531
532 for (handler = thread->m_handlerlist; handler; handler = handler->next)
533 {
534 mark_object (handler->tag_or_ch);
535 mark_object (handler->val);
536 }
537
538 if (thread->m_current_buffer)
539 {
540 XSETBUFFER (tem, thread->m_current_buffer);
541 mark_object (tem);
542 }
543
544 mark_object (thread->m_last_thing_searched);
545
546 if (thread->m_saved_last_thing_searched)
547 mark_object (thread->m_saved_last_thing_searched);
548}
549
550static void
551mark_threads_callback (void *ignore)
552{
553 struct thread_state *iter;
554
555 for (iter = all_threads; iter; iter = iter->next_thread)
556 {
557 Lisp_Object thread_obj;
558
559 XSETTHREAD (thread_obj, iter);
560 mark_object (thread_obj);
561 mark_one_thread (iter);
562 }
563}
564
565void
566mark_threads (void)
567{
568 flush_stack_call_func (mark_threads_callback, NULL);
569}
570
571void
572unmark_threads (void)
573{
574 struct thread_state *iter;
575
576 for (iter = all_threads; iter; iter = iter->next_thread)
577 if (iter->m_byte_stack_list)
578 relocate_byte_stack (iter->m_byte_stack_list);
579}
580
581
582
583static void
584yield_callback (void *ignore)
585{
586 struct thread_state *self = current_thread;
587
588 release_global_lock ();
589 sys_thread_yield ();
590 acquire_global_lock (self);
591}
592
593DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
594 doc: /* Yield the CPU to another thread. */)
595 (void)
596{
597 flush_stack_call_func (yield_callback, NULL);
598 return Qnil;
599}
600
601static Lisp_Object
602invoke_thread_function (void)
603{
604 Lisp_Object iter;
605 volatile struct thread_state *self = current_thread;
606
607 int count = SPECPDL_INDEX ();
608
609 Ffuncall (1, &current_thread->function);
610 return unbind_to (count, Qnil);
611}
612
613static Lisp_Object
614do_nothing (Lisp_Object whatever)
615{
616 return whatever;
617}
618
619static void *
620run_thread (void *state)
621{
622 char stack_pos;
623 struct thread_state *self = state;
624 struct thread_state **iter;
625
626 self->m_stack_bottom = &stack_pos;
627 self->stack_top = &stack_pos;
628 self->thread_id = sys_thread_self ();
629
630 acquire_global_lock (self);
631
632 { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
633 This is important since handlerlist->nextfree holds the freelist
634 which would otherwise leak every time we unwind back to top-level. */
635 handlerlist_sentinel = xzalloc (sizeof (struct handler));
636 handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
637 struct handler *c = push_handler (Qunbound, CATCHER);
638 eassert (c == handlerlist_sentinel);
639 handlerlist_sentinel->nextfree = NULL;
640 handlerlist_sentinel->next = NULL;
641 }
642
643 /* It might be nice to do something with errors here. */
644 internal_condition_case (invoke_thread_function, Qt, do_nothing);
645
646 update_processes_for_thread_death (Fcurrent_thread ());
647
648 xfree (self->m_specpdl - 1);
649 self->m_specpdl = NULL;
650 self->m_specpdl_ptr = NULL;
651 self->m_specpdl_size = 0;
652
653 {
654 struct handler *c, *c_next;
655 for (c = handlerlist_sentinel; c; c = c_next)
656 {
657 c_next = c->nextfree;
658 xfree (c);
659 }
660 }
661
662 current_thread = NULL;
663 sys_cond_broadcast (&self->thread_condvar);
664
665 /* Unlink this thread from the list of all threads. Note that we
666 have to do this very late, after broadcasting our death.
667 Otherwise the GC may decide to reap the thread_state object,
668 leading to crashes. */
669 for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
670 ;
671 *iter = (*iter)->next_thread;
672
673 release_global_lock ();
674
675 return NULL;
676}
677
678void
679finalize_one_thread (struct thread_state *state)
680{
681 sys_cond_destroy (&state->thread_condvar);
682}
683
684DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
685 doc: /* Start a new thread and run FUNCTION in it.
686When the function exits, the thread dies.
687If NAME is given, it names the new thread. */)
688 (Lisp_Object function, Lisp_Object name)
689{
690 sys_thread_t thr;
691 struct thread_state *new_thread;
692 Lisp_Object result;
693 const char *c_name = NULL;
694 size_t offset = offsetof (struct thread_state, m_byte_stack_list);
695
696 /* Can't start a thread in temacs. */
697 if (!initialized)
698 abort ();
699
700 if (!NILP (name))
701 CHECK_STRING (name);
702
703 new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_byte_stack_list,
704 PVEC_THREAD);
705 memset ((char *) new_thread + offset, 0,
706 sizeof (struct thread_state) - offset);
707
708 new_thread->function = function;
709 new_thread->name = name;
710 new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
711 new_thread->m_saved_last_thing_searched = Qnil;
712 new_thread->m_current_buffer = current_thread->m_current_buffer;
713 new_thread->error_symbol = Qnil;
714 new_thread->error_data = Qnil;
715 new_thread->event_object = Qnil;
716
717 new_thread->m_specpdl_size = 50;
718 new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
719 * sizeof (union specbinding));
720 /* Skip the dummy entry. */
721 ++new_thread->m_specpdl;
722 new_thread->m_specpdl_ptr = new_thread->m_specpdl;
723
724 sys_cond_init (&new_thread->thread_condvar);
725
726 /* We'll need locking here eventually. */
727 new_thread->next_thread = all_threads;
728 all_threads = new_thread;
729
730 if (!NILP (name))
731 c_name = SSDATA (ENCODE_UTF_8 (name));
732
733 if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
734 {
735 /* Restore the previous situation. */
736 all_threads = all_threads->next_thread;
737 error ("Could not start a new thread");
738 }
739
740 /* FIXME: race here where new thread might not be filled in? */
741 XSETTHREAD (result, new_thread);
742 return result;
743}
744
745DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
746 doc: /* Return the current thread. */)
747 (void)
748{
749 Lisp_Object result;
750 XSETTHREAD (result, current_thread);
751 return result;
752}
753
754DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
755 doc: /* Return the name of the THREAD.
756The name is the same object that was passed to `make-thread'. */)
757 (Lisp_Object thread)
758{
759 struct thread_state *tstate;
760
761 CHECK_THREAD (thread);
762 tstate = XTHREAD (thread);
763
764 return tstate->name;
765}
766
767static void
768thread_signal_callback (void *arg)
769{
770 struct thread_state *tstate = arg;
771 struct thread_state *self = current_thread;
772
773 sys_cond_broadcast (tstate->wait_condvar);
774 post_acquire_global_lock (self);
775}
776
777DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
778 doc: /* Signal an error in a thread.
779This acts like `signal', but arranges for the signal to be raised
780in THREAD. If THREAD is the current thread, acts just like `signal'.
781This will interrupt a blocked call to `mutex-lock', `condition-wait',
782or `thread-join' in the target thread. */)
783 (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
784{
785 struct thread_state *tstate;
786
787 CHECK_THREAD (thread);
788 tstate = XTHREAD (thread);
789
790 if (tstate == current_thread)
791 Fsignal (error_symbol, data);
792
793 /* What to do if thread is already signalled? */
794 /* What if error_symbol is Qnil? */
795 tstate->error_symbol = error_symbol;
796 tstate->error_data = data;
797
798 if (tstate->wait_condvar)
799 flush_stack_call_func (thread_signal_callback, tstate);
800
801 return Qnil;
802}
803
804DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
805 doc: /* Return t if THREAD is alive, or nil if it has exited. */)
806 (Lisp_Object thread)
807{
808 struct thread_state *tstate;
809
810 CHECK_THREAD (thread);
811 tstate = XTHREAD (thread);
812
813 return thread_alive_p (tstate) ? Qt : Qnil;
814}
815
816DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
817 doc: /* Return the object that THREAD is blocking on.
818If THREAD is blocked in `thread-join' on a second thread, return that
819thread.
820If THREAD is blocked in `mutex-lock', return the mutex.
821If THREAD is blocked in `condition-wait', return the condition variable.
822Otherwise, if THREAD is not blocked, return nil. */)
823 (Lisp_Object thread)
824{
825 struct thread_state *tstate;
826
827 CHECK_THREAD (thread);
828 tstate = XTHREAD (thread);
829
830 return tstate->event_object;
831}
832
833static void
834thread_join_callback (void *arg)
835{
836 struct thread_state *tstate = arg;
837 struct thread_state *self = current_thread;
838 Lisp_Object thread;
839
840 XSETTHREAD (thread, tstate);
841 self->event_object = thread;
842 self->wait_condvar = &tstate->thread_condvar;
843 while (thread_alive_p (tstate) && NILP (self->error_symbol))
844 sys_cond_wait (self->wait_condvar, &global_lock);
845
846 self->wait_condvar = NULL;
847 self->event_object = Qnil;
848 post_acquire_global_lock (self);
849}
850
851DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
852 doc: /* Wait for a thread to exit.
853This blocks the current thread until THREAD exits.
854It is an error for a thread to try to join itself. */)
855 (Lisp_Object thread)
856{
857 struct thread_state *tstate;
858
859 CHECK_THREAD (thread);
860 tstate = XTHREAD (thread);
861
862 if (tstate == current_thread)
863 error ("cannot join current thread");
864
865 if (thread_alive_p (tstate))
866 flush_stack_call_func (thread_join_callback, tstate);
867
868 return Qnil;
869}
870
871DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
872 doc: /* Return a list of all threads. */)
873 (void)
874{
875 Lisp_Object result = Qnil;
876 struct thread_state *iter;
877
878 for (iter = all_threads; iter; iter = iter->next_thread)
879 {
880 if (thread_alive_p (iter))
881 {
882 Lisp_Object thread;
883
884 XSETTHREAD (thread, iter);
885 result = Fcons (thread, result);
886 }
887 }
888
889 return result;
890}
891
892
893
894bool
895thread_check_current_buffer (struct buffer *buffer)
896{
897 struct thread_state *iter;
898
899 for (iter = all_threads; iter; iter = iter->next_thread)
900 {
901 if (iter == current_thread)
902 continue;
903
904 if (iter->m_current_buffer == buffer)
905 return true;
906 }
907
908 return false;
909}
910
911
912
913static void
914init_primary_thread (void)
915{
916 primary_thread.header.size
917 = PSEUDOVECSIZE (struct thread_state, m_byte_stack_list);
918 XSETPVECTYPE (&primary_thread, PVEC_THREAD);
919 primary_thread.m_last_thing_searched = Qnil;
920 primary_thread.m_saved_last_thing_searched = Qnil;
921 primary_thread.name = Qnil;
922 primary_thread.function = Qnil;
923 primary_thread.error_symbol = Qnil;
924 primary_thread.error_data = Qnil;
925 primary_thread.event_object = Qnil;
926}
927
928void
929init_threads_once (void)
930{
931 init_primary_thread ();
932}
933
934void
935init_threads (void)
936{
937 init_primary_thread ();
938 sys_cond_init (&primary_thread.thread_condvar);
939 sys_mutex_init (&global_lock);
940 sys_mutex_lock (&global_lock);
941 current_thread = &primary_thread;
942 primary_thread.thread_id = sys_thread_self ();
943}
944
945void
946syms_of_threads (void)
947{
948#ifndef THREADS_ENABLED
949 if (0)
950#endif
951 {
952 defsubr (&Sthread_yield);
953 defsubr (&Smake_thread);
954 defsubr (&Scurrent_thread);
955 defsubr (&Sthread_name);
956 defsubr (&Sthread_signal);
957 defsubr (&Sthread_alive_p);
958 defsubr (&Sthread_join);
959 defsubr (&Sthread_blocker);
960 defsubr (&Sall_threads);
961 defsubr (&Smake_mutex);
962 defsubr (&Smutex_lock);
963 defsubr (&Smutex_unlock);
964 defsubr (&Smutex_name);
965 defsubr (&Smake_condition_variable);
966 defsubr (&Scondition_wait);
967 defsubr (&Scondition_notify);
968 defsubr (&Scondition_mutex);
969 defsubr (&Scondition_name);
970 }
971
972 DEFSYM (Qthreadp, "threadp");
973 DEFSYM (Qmutexp, "mutexp");
974 DEFSYM (Qcondition_variable_p, "condition-variable-p");
975}
diff --git a/src/thread.h b/src/thread.h
new file mode 100644
index 00000000000..a089c7de573
--- /dev/null
+++ b/src/thread.h
@@ -0,0 +1,248 @@
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 "regex.h"
23
24#ifdef WINDOWSNT
25#include <sys/socket.h>
26#endif
27
28#include "sysselect.h" /* FIXME */
29#include "systime.h" /* FIXME */
30
31struct thread_state
32{
33 struct vectorlike_header header;
34
35 /* The buffer in which the last search was performed, or
36 Qt if the last search was done in a string;
37 Qnil if no searching has been done yet. */
38 Lisp_Object m_last_thing_searched;
39#define last_thing_searched (current_thread->m_last_thing_searched)
40
41 Lisp_Object m_saved_last_thing_searched;
42#define saved_last_thing_searched (current_thread->m_saved_last_thing_searched)
43
44 /* The thread's name. */
45 Lisp_Object name;
46
47 /* The thread's function. */
48 Lisp_Object function;
49
50 /* If non-nil, this thread has been signalled. */
51 Lisp_Object error_symbol;
52 Lisp_Object error_data;
53
54 /* If we are waiting for some event, this holds the object we are
55 waiting on. */
56 Lisp_Object event_object;
57
58 /* m_byte_stack_list must be the first non-lisp field. */
59 /* A list of currently active byte-code execution value stacks.
60 Fbyte_code adds an entry to the head of this list before it starts
61 processing byte-code, and it removed the entry again when it is
62 done. Signalling an error truncates the list. */
63 struct byte_stack *m_byte_stack_list;
64#define byte_stack_list (current_thread->m_byte_stack_list)
65
66 /* An address near the bottom of the stack.
67 Tells GC how to save a copy of the stack. */
68 char *m_stack_bottom;
69#define stack_bottom (current_thread->m_stack_bottom)
70
71 /* An address near the top of the stack. */
72 char *stack_top;
73
74 struct catchtag *m_catchlist;
75#define catchlist (current_thread->m_catchlist)
76
77 /* Chain of condition handlers currently in effect.
78 The elements of this chain are contained in the stack frames
79 of Fcondition_case and internal_condition_case.
80 When an error is signaled (by calling Fsignal, below),
81 this chain is searched for an element that applies. */
82 struct handler *m_handlerlist;
83#define handlerlist (current_thread->m_handlerlist)
84
85 struct handler *m_handlerlist_sentinel;
86#define handlerlist_sentinel (current_thread->m_handlerlist_sentinel)
87
88 /* Current number of specbindings allocated in specpdl. */
89 ptrdiff_t m_specpdl_size;
90#define specpdl_size (current_thread->m_specpdl_size)
91
92 /* Pointer to beginning of specpdl. */
93 union specbinding *m_specpdl;
94#define specpdl (current_thread->m_specpdl)
95
96 /* Pointer to first unused element in specpdl. */
97 union specbinding *m_specpdl_ptr;
98#define specpdl_ptr (current_thread->m_specpdl_ptr)
99
100 /* Depth in Lisp evaluations and function calls. */
101 EMACS_INT m_lisp_eval_depth;
102#define lisp_eval_depth (current_thread->m_lisp_eval_depth)
103
104 /* This points to the current buffer. */
105 struct buffer *m_current_buffer;
106#define current_buffer (current_thread->m_current_buffer)
107
108 /* Every call to re_match, etc., must pass &search_regs as the regs
109 argument unless you can show it is unnecessary (i.e., if re_match
110 is certainly going to be called again before region-around-match
111 can be called).
112
113 Since the registers are now dynamically allocated, we need to make
114 sure not to refer to the Nth register before checking that it has
115 been allocated by checking search_regs.num_regs.
116
117 The regex code keeps track of whether it has allocated the search
118 buffer using bits in the re_pattern_buffer. This means that whenever
119 you compile a new pattern, it completely forgets whether it has
120 allocated any registers, and will allocate new registers the next
121 time you call a searching or matching function. Therefore, we need
122 to call re_set_registers after compiling a new pattern or after
123 setting the match registers, so that the regex functions will be
124 able to free or re-allocate it properly. */
125 struct re_registers m_search_regs;
126#define search_regs (current_thread->m_search_regs)
127
128 /* If non-zero the match data have been saved in saved_search_regs
129 during the execution of a sentinel or filter. */
130 bool m_search_regs_saved;
131#define search_regs_saved (current_thread->m_search_regs_saved)
132
133 struct re_registers m_saved_search_regs;
134#define saved_search_regs (current_thread->m_saved_search_regs)
135
136 /* This is the string or buffer in which we
137 are matching. It is used for looking up syntax properties.
138
139 If the value is a Lisp string object, we are matching text in that
140 string; if it's nil, we are matching text in the current buffer; if
141 it's t, we are matching text in a C string. */
142 Lisp_Object m_re_match_object;
143#define re_match_object (current_thread->m_re_match_object)
144
145 /* Set by `re_set_syntax' to the current regexp syntax to recognize. Can
146 also be assigned to arbitrarily: each pattern buffer stores its own
147 syntax, so it can be changed between regex compilations. */
148 reg_syntax_t m_re_syntax_options;
149#define re_syntax_options (current_thread->m_re_syntax_options)
150
151 /* Regexp to use to replace spaces, or NULL meaning don't. */
152 /* This ought to be a "const re_char *" but that is not available
153 outside regex.h. */
154 const void *m_whitespace_regexp;
155#define whitespace_regexp (current_thread->m_whitespace_regexp)
156
157 /* This variable is different from waiting_for_input in keyboard.c.
158 It is used to communicate to a lisp process-filter/sentinel (via the
159 function Fwaiting_for_user_input_p) whether Emacs was waiting
160 for user-input when that process-filter was called.
161 waiting_for_input cannot be used as that is by definition 0 when
162 lisp code is being evalled.
163 This is also used in record_asynch_buffer_change.
164 For that purpose, this must be 0
165 when not inside wait_reading_process_output. */
166 int m_waiting_for_user_input_p;
167#define waiting_for_user_input_p (current_thread->m_waiting_for_user_input_p)
168
169 /* The OS identifier for this thread. */
170 sys_thread_t thread_id;
171
172 /* The condition variable for this thread. This is associated with
173 the global lock. This thread broadcasts to it when it exits. */
174 sys_cond_t thread_condvar;
175
176 /* This thread might be waiting for some condition. If so, this
177 points to the condition. If the thread is interrupted, the
178 interrupter should broadcast to this condition. */
179 sys_cond_t *wait_condvar;
180
181 /* Threads are kept on a linked list. */
182 struct thread_state *next_thread;
183};
184
185/* A mutex in lisp is represented by a system condition variable.
186 The system mutex associated with this condition variable is the
187 global lock.
188
189 Using a condition variable lets us implement interruptibility for
190 lisp mutexes. */
191typedef struct
192{
193 /* The owning thread, or NULL if unlocked. */
194 struct thread_state *owner;
195 /* The lock count. */
196 unsigned int count;
197 /* The underlying system condition variable. */
198 sys_cond_t condition;
199} lisp_mutex_t;
200
201/* A mutex as a lisp object. */
202struct Lisp_Mutex
203{
204 struct vectorlike_header header;
205
206 /* The name of the mutex, or nil. */
207 Lisp_Object name;
208
209 /* The lower-level mutex object. */
210 lisp_mutex_t mutex;
211};
212
213/* A condition variable as a lisp object. */
214struct Lisp_CondVar
215{
216 struct vectorlike_header header;
217
218 /* The associated mutex. */
219 Lisp_Object mutex;
220
221 /* The name of the condition variable, or nil. */
222 Lisp_Object name;
223
224 /* The lower-level condition variable object. */
225 sys_cond_t cond;
226};
227
228extern struct thread_state *current_thread;
229
230extern void unmark_threads (void);
231extern void finalize_one_thread (struct thread_state *state);
232extern void finalize_one_mutex (struct Lisp_Mutex *);
233extern void finalize_one_condvar (struct Lisp_CondVar *);
234
235extern void init_threads_once (void);
236extern void init_threads (void);
237extern void syms_of_threads (void);
238
239typedef int select_func (int, fd_set *, fd_set *, fd_set *,
240 struct timespec *, sigset_t *);
241
242int thread_select (select_func *func, int max_fds, fd_set *rfds,
243 fd_set *wfds, fd_set *efds, struct timespec *timeout,
244 sigset_t *sigmask);
245
246bool thread_check_current_buffer (struct buffer *);
247
248#endif /* THREAD_H */
diff --git a/src/w32.c b/src/w32.c
index 086c1acfb38..7a80275a7c8 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 struct timespec *, sigset_t *);
276extern int sys_dup (int); 276extern int sys_dup (int);
277 277
278 278
diff --git a/src/w32.h b/src/w32.h
index 702bb5255cd..760bb14c00d 100644
--- a/src/w32.h
+++ b/src/w32.h
@@ -25,7 +25,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 25
26#include <windows.h> 26#include <windows.h>
27 27
28
29/* File descriptor set emulation. */ 28/* File descriptor set emulation. */
30 29
31/* MSVC runtime library has limit of 64 descriptors by default */ 30/* MSVC runtime library has limit of 64 descriptors by default */
diff --git a/src/w32proc.c b/src/w32proc.c
index 189034c4e2d..2d2d948bfea 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -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 struct timespec *timeout, 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 acbefcdad16..9460057262c 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..e418e1a3c4e 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,8 @@ 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 gfds = xnmalloc (n_gfds, sizeof *gfds);
80 must_free = 1;
81 gfds_size = n_gfds; 81 gfds_size = n_gfds;
82 n_gfds = g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec, 82 n_gfds = g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec,
83 gfds, gfds_size); 83 gfds, gfds_size);
@@ -98,7 +98,8 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds,
98 } 98 }
99 } 99 }
100 100
101 SAFE_FREE (); 101 if (must_free)
102 xfree (gfds);
102 103
103 if (n_gfds >= 0 && tmo_in_millisec >= 0) 104 if (n_gfds >= 0 && tmo_in_millisec >= 0)
104 { 105 {
generated by cgit v1.2.1 (git 2.18.0) at 2026-03-17 22:53:40 +0000