[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 2412a1f: Support concurrency in Emacs Lisp
|
From: |
Eli Zaretskii |
|
Subject: |
[Emacs-diffs] master 2412a1f: Support concurrency in Emacs Lisp |
|
Date: |
Sat, 10 Dec 2016 17:08:08 +0000 (UTC) |
branch: master
commit 2412a1fc05fe9f89b171d0781c2d530923f48adc
Merge: fc0fd24 828b456
Author: Eli Zaretskii <address@hidden>
Commit: Eli Zaretskii <address@hidden>
Support concurrency in Emacs Lisp
Merge branch 'test-concurrency'
* src/thread.c:
* src/thread.h:
* src/systhread.c:
* src/systhread.h: New files.
* src/xgselect.c (xg_select): Avoid using SAFE_NALLOCA and use
xnmalloc unconditionally.
* src/window.c (struct save_window_data): Rename current_buffer to
f_current_buffer.
* src/w32proc.c (sys_select): Change the function signature to
closer fit 'pselect' on Posix hosts.
* src/search.c:
* src/regex.h: Convert some globals to macros that reference
thread-specific values.
* src/process.c (pset_thread, add_non_keyboard_read_fd)
(add_process_read_fd, add_non_blocking_write_fd)
(recompute_input_desc, compute_input_wait_mask)
(compute_non_process_wait_mask, compute_non_keyboard_wait_mask)
(compute_write_mask, clear_waiting_thread_info)
(update_processes_for_thread_death, Fset_process_thread)
(Fprocess_thread): New functions.
(enum fd_bits): New enumeration.
(fd_callback_data): Add 'thread' and 'waiting_thread', rename
'condition' to 'flags'.
(set_process_filter_masks, create_process, create_pty)
(Fmake_serial_process, finish_after_tls_connection)
(connect_network_socket, deactivate_process)
(server_accept_connection, wait_reading_process_output)
(Fcontinue_process, Fstop_process, keyboard_bit_set)
(add_timer_wait_descriptor, add_keyboard_wait_descriptor)
(delete_keyboard_wait_descriptor): Use the new functions instead
of manipulating fd flags and masks directly.
(syms_of_process): Defsubr the new primitives.
* src/print.c (print_object): Print threads, mutexes, and
conditional variables.
* src/lisp.h (enum pvec_type): New values PVEC_THREAD, PVEC_MUTEX,
and PVEC_CONDVAR.
(XTHREAD, XMUTEX, XCONDVAR, THREADP, MUTEXP, CONDVARP)
(CHECK_THREAD, CHECK_MUTEX, CHECK_CONDVAR): New inline functions.
(XSETTHREAD, XSETMUTEX, XSETCONDVAR): New macros.
(struct handler): Add back byte_stack. Rename lisp_eval_depth to
f_lisp_eval_depth.
* src/eval.c (specpdl_kind, specpdl_arg, do_specbind)
(rebind_for_thread_switch, do_one_unbind)
(unbind_for_thread_switch): New functions.
(init_eval): 'handlerlist' is not malloc'ed.
(specbind): Call do_specbind.
(unbind_to): Call do_one_unbind.
(mark_specpdl): Accept 2 arguments.
(mark_specpdl): Mark the saved value in a let-binding.
* src/emacs.c (main): Call init_threads_once, init_threads, and
syms_of_threads.
* src/data.c (Ftype_of): Support thread, mutex, and condvar
objects.
(Fthreadp, Fmutexp, Fcondition_variable_p): New functions.
(syms_of_data): DEFSYM and defsubr new symbols and primitives.
* src/bytecode.c (struct byte_stack, FETCH, CHECK_RANGE)
(BYTE_CODE_QUIT): Add back.
(exec_byte_code): Add back byte stack manipulation.
* src/alloc.c (cleanup_vector): Handle threads, mutexes, and
conditional variables.
(mark_stack): Now extern; accept additional argument 'bottom'.
(flush_stack_call_func): New function.
(garbage_collect_1): Call mark_threads and unmark_threads. Don't
mark handlers.
* src/.gdbinit (xbytecode): Add back.
* test/src/thread-tests.el: New tests.
* test/src/data-tests.el (binding-test-manual)
(binding-test-setq-default, binding-test-makunbound)
(binding-test-defvar-bool, binding-test-defvar-int)
(binding-test-set-constant-t, binding-test-set-constant-nil)
(binding-test-set-constant-keyword)
(binding-test-set-constant-nil): New tests.
* doc/lispref/processes.texi (Processes and Threads): New
subsection.
* doc/lispref/threads.texi: New file
* doc/lispref/elisp.texi (Top): Include it.
* doc/lispref/objects.texi (Thread Type, Mutex Type)
(Condition Variable Type): New subsections.
(Type Predicates): Add thread-related predicates.
* doc/lispref/objects.texi (Editing Types):
* doc/lispref/elisp.texi (Top): Update higher-level menus.
* etc/NEWS: Mention concurrency features.
---
configure.ac | 22 +-
doc/lispref/Makefile.in | 1 +
doc/lispref/elisp.texi | 11 +
doc/lispref/objects.texi | 89 +++-
doc/lispref/processes.texi | 30 ++
doc/lispref/threads.texi | 252 ++++++++++++
etc/DEBUG | 2 +-
etc/NEWS | 13 +
lisp/subr.el | 14 +
nt/inc/sys/socket.h | 1 +
src/.gdbinit | 15 +
src/Makefile.in | 1 +
src/alloc.c | 110 ++++-
src/buffer.c | 5 +-
src/buffer.h | 4 -
src/bytecode.c | 203 ++++++---
src/data.c | 39 ++
src/emacs.c | 14 +-
src/eval.c | 268 ++++++++----
src/lisp.h | 162 ++++++--
src/print.c | 36 ++
src/process.c | 547 +++++++++++++++----------
src/process.h | 5 +
src/regex.c | 6 -
src/regex.h | 8 +-
src/search.c | 22 +-
src/sysdep.c | 9 +-
src/systhread.c | 417 +++++++++++++++++++
src/systhread.h | 112 +++++
src/thread.c | 970 ++++++++++++++++++++++++++++++++++++++++++++
src/thread.h | 237 +++++++++++
src/w32.c | 2 +-
src/w32proc.c | 8 +-
src/window.c | 8 +-
src/xgselect.c | 12 +-
test/src/data-tests.el | 81 ++++
test/src/thread-tests.el | 213 ++++++++++
37 files changed, 3497 insertions(+), 452 deletions(-)
diff --git a/configure.ac b/configure.ac
index 2d116de..5aaf006 100644
--- a/configure.ac
+++ b/configure.ac
@@ -355,6 +355,7 @@ OPTION_DEFAULT_ON([selinux],[don't compile with SELinux
support])
OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support])
OPTION_DEFAULT_ON([zlib],[don't compile with zlib decompression support])
OPTION_DEFAULT_OFF([modules],[compile with dynamic modules support])
+OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support])
AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB],
[use a file notification library (LIB one of: yes, inotify, kqueue, gfile,
w32, no)])],
@@ -1643,7 +1644,7 @@ AC_CHECK_HEADERS_ONCE(
sys/sysinfo.h
coff.h pty.h
sys/resource.h
- sys/utsname.h pwd.h utmp.h util.h)
+ sys/utsname.h pwd.h utmp.h util.h sys/prctl.h)
AC_CACHE_CHECK([for ADDR_NO_RANDOMIZE],
[emacs_cv_personality_addr_no_randomize],
@@ -2305,6 +2306,22 @@ if test "$ac_cv_header_pthread_h" && test "$opsys" !=
"mingw32"; then
fi
AC_SUBST([LIB_PTHREAD])
+AC_MSG_CHECKING([for thread support])
+threads_enabled=no
+if test "$with_threads" = yes; then
+ if test "$emacs_cv_pthread_lib" != no; then
+ AC_DEFINE(THREADS_ENABLED, 1,
+ [Define to 1 if you want elisp thread support.])
+ threads_enabled=yes
+ elif test "${opsys}" = "mingw32"; then
+ dnl MinGW can do native Windows threads even without pthreads
+ AC_DEFINE(THREADS_ENABLED, 1,
+ [Define to 1 if you want elisp thread support.])
+ threads_enabled=yes
+ fi
+fi
+AC_MSG_RESULT([$threads_enabled])
+
dnl Check for need for bigtoc support on IBM AIX
case ${host_os} in
@@ -3871,7 +3888,7 @@ pthread_sigmask strsignal setitimer \
sendto recvfrom getsockname getifaddrs freeifaddrs \
gai_strerror sync \
getpwent endpwent getgrent endgrent \
-cfmakeraw cfsetspeed copysign __executable_start log2)
+cfmakeraw cfsetspeed copysign __executable_start log2 prctl)
LIBS=$OLD_LIBS
dnl No need to check for posix_memalign if aligned_alloc works.
@@ -5314,6 +5331,7 @@ AS_ECHO([" Does Emacs use -lXaw3d?
${HAVE_XAW3D
Does Emacs have dynamic modules support? ${HAVE_MODULES}
Does Emacs use toolkit scroll bars?
${USE_TOOLKIT_SCROLL_BARS}
Does Emacs support Xwidgets (requires gtk3)? ${HAVE_XWIDGETS}
+ Does Emacs have threading support in lisp? ${threads_enabled}
"])
if test -n "${EMACSDATA}"; then
diff --git a/doc/lispref/Makefile.in b/doc/lispref/Makefile.in
index 7aadee7..5bf6e99 100644
--- a/doc/lispref/Makefile.in
+++ b/doc/lispref/Makefile.in
@@ -125,6 +125,7 @@ srcs = \
$(srcdir)/symbols.texi \
$(srcdir)/syntax.texi \
$(srcdir)/text.texi \
+ $(srcdir)/threads.texi \
$(srcdir)/tips.texi \
$(srcdir)/variables.texi \
$(srcdir)/windows.texi \
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index 6983ab7..4a53a0c 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -219,6 +219,7 @@ To view this manual in other formats, click
* Syntax Tables:: The syntax table controls word and list parsing.
* Abbrevs:: How Abbrev mode works, and its data structures.
+* Threads:: Concurrency in Emacs Lisp.
* Processes:: Running and communicating with subprocesses.
* Display:: Features for controlling the screen display.
* System Interface:: Getting the user id, system type, environment
@@ -348,6 +349,9 @@ Editing Types
* Window Configuration Type:: Recording the way a frame is subdivided.
* Frame Configuration Type:: Recording the status of all frames.
* Process Type:: A subprocess of Emacs running on the underlying OS.
+* Thread Type:: A thread of Emacs Lisp execution.
+* Mutex Type:: An exclusive lock for thread synchronization.
+* Condition Variable Type:: Condition variable for thread synchronization.
* Stream Type:: Receive or send characters.
* Keymap Type:: What function a keystroke invokes.
* Overlay Type:: How an overlay is represented.
@@ -1322,6 +1326,12 @@ Abbrevs and Abbrev Expansion
* Abbrev Table Properties:: How to read and set abbrev table properties.
Which properties have which effect.
+Threads
+
+* Basic Thread Functions:: Basic thread functions.
+* Mutexes:: Mutexes allow exclusive access to data.
+* Condition Variables:: Inter-thread events.
+
Processes
* Subprocess Creation:: Functions that start subprocesses.
@@ -1628,6 +1638,7 @@ Object Internals
@include searching.texi
@include syntax.texi
@include abbrevs.texi
address@hidden threads.texi
@include processes.texi
@include display.texi
diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi
index 54894b8..5e608bc 100644
--- a/doc/lispref/objects.texi
+++ b/doc/lispref/objects.texi
@@ -1410,6 +1410,9 @@ editing.
* Window Configuration Type:: Recording the way a frame is subdivided.
* Frame Configuration Type:: Recording the status of all frames.
* Process Type:: A subprocess of Emacs running on the underlying OS.
+* Thread Type:: A thread of Emacs Lisp execution.
+* Mutex Type:: An exclusive lock for thread synchronization.
+* Condition Variable Type:: Condition variable for thread synchronization.
* Stream Type:: Receive or send characters.
* Keymap Type:: What function a keystroke invokes.
* Overlay Type:: How an overlay is represented.
@@ -1625,6 +1628,63 @@ giving the name of the process:
return information about, send input or signals to, and receive output
from processes.
address@hidden Thread Type
address@hidden Thread Type
+
+ A @dfn{thread} in Emacs represents a separate thread of Emacs Lisp
+execution. It runs its own Lisp program, has its own current buffer,
+and can have subprocesses locked to it, i.e.@: subprocesses whose
+output only this thread can accept. @xref{Threads}.
+
+ Thread objects have no read syntax. They print in hash notation,
+giving the name of the thread (if it has been given a name) or its
+address in core:
+
address@hidden
address@hidden
+(all-threads)
+ @result{} (#<thread 0176fc40>)
address@hidden group
address@hidden example
+
address@hidden Mutex Type
address@hidden Mutex Type
+
+ A @dfn{mutex} is an exclusive lock that threads can own and disown,
+in order to synchronize between them. @xref{Mutexes}.
+
+ Mutex objects have no read syntax. They print in hash notation,
+giving the name of the mutex (if it has been given a name) or its
+address in core:
+
address@hidden
address@hidden
+(make-mutex "my-mutex")
+ @result{} #<mutex my-mutex>
+(make-mutex)
+ @result{} #<mutex 01c7e4e0>
address@hidden group
address@hidden example
+
address@hidden Condition Variable Type
address@hidden Condition Variable Type
+
+ A @dfn{condition variable} is a device for a more complex thread
+synchronization than the one supported by a mutex. A thread can wait
+on a condition variable, to be woken up when some other thread
+notifies the condition.
+
+ Condition variable objects have no read syntax. They print in hash
+notation, giving the name of the condition variable (if it has been
+given a name) or its address in core:
+
address@hidden
address@hidden
+(make-condition-variable (make-mutex))
+ @result{} #<condvar 01c45ae8>
address@hidden group
address@hidden example
+
@node Stream Type
@subsection Stream Type
@@ -1830,6 +1890,9 @@ with references to further information.
@item commandp
@xref{Interactive Call, commandp}.
address@hidden condition-variable-p
address@hidden Variables, condition-variable-p}.
+
@item consp
@xref{List-related Predicates, consp}.
@@ -1875,6 +1938,9 @@ with references to further information.
@item markerp
@xref{Predicates on Markers, markerp}.
address@hidden mutexp
address@hidden, mutexp}.
+
@item wholenump
@xref{Predicates on Numbers, wholenump}.
@@ -1908,6 +1974,9 @@ with references to further information.
@item syntax-table-p
@xref{Syntax Tables, syntax-table-p}.
address@hidden threadp
address@hidden Thread Functions, threadp}.
+
@item vectorp
@xref{Vectors, vectorp}.
@@ -1925,6 +1994,15 @@ with references to further information.
@item string-or-null-p
@xref{Predicates for Strings, string-or-null-p}.
+
address@hidden threadp
address@hidden Thread Functions, threadp}.
+
address@hidden mutexp
address@hidden, mutexp}.
+
address@hidden condition-variable-p
address@hidden Variables, condition-variable-p}.
@end table
The most general way to check the type of an object is to call the
@@ -1938,11 +2016,12 @@ types. In most cases, it is more convenient to use
type predicates than
This function returns a symbol naming the primitive type of
@var{object}. The value is one of the symbols @code{bool-vector},
@code{buffer}, @code{char-table}, @code{compiled-function},
address@hidden, @code{finalizer}, @code{float}, @code{font-entity},
address@hidden, @code{font-spec}, @code{frame}, @code{hash-table},
address@hidden, @code{marker}, @code{overlay}, @code{process},
address@hidden, @code{subr}, @code{symbol}, @code{vector},
address@hidden, or @code{window-configuration}.
address@hidden, @code{cons}, @code{finalizer},
address@hidden, @code{font-entity}, @code{font-object},
address@hidden, @code{frame}, @code{hash-table}, @code{integer},
address@hidden, @code{mutex}, @code{overlay}, @code{process},
address@hidden, @code{subr}, @code{symbol}, @code{thread},
address@hidden, @code{window}, or @code{window-configuration}.
@example
(type-of 1)
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index 21e1429..064934c 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -1400,6 +1400,7 @@ Emacs tries to read it.
* Filter Functions:: Filter functions accept output from the process.
* Decoding Output:: Filters can get unibyte or multibyte strings.
* Accepting Output:: How to wait until process output arrives.
+* Processes and Threads:: How processes and threads interact.
@end menu
@node Process Buffers
@@ -1791,6 +1792,35 @@ got output from @var{process}, or from any process if
@var{process} is
arrived.
@end defun
address@hidden Processes and Threads
address@hidden Processes and Threads
address@hidden processes, threads
+
+ Because threads were a relatively late addition to Emacs Lisp, and
+due to the way dynamic binding was sometimes used in conjunction with
address@hidden, by default a process is locked to the
+thread that created it. When a process is locked to a thread, output
+from the process can only be accepted by that thread.
+
+ A Lisp program can specify to which thread a process is to be
+locked, or instruct Emacs to unlock a process, in which case its
+output can be processed by any thread. Only a single thread will wait
+for output from a given process at one time---once one thread begins
+waiting for output, the process is temporarily locked until
address@hidden or @code{sit-for} returns.
+
+ If the thread exits, all the processes locked to it are unlocked.
+
address@hidden process-thread process
+Return the thread to which @var{process} is locked. If @var{process}
+is unlocked, return @code{nil}.
address@hidden defun
+
address@hidden set-process-thread process thread
+Set the locking thread of @var{process} to @var{thread}. @var{thread}
+may be @code{nil}, in which case the process is unlocked.
address@hidden defun
+
@node Sentinels
@section Sentinels: Detecting Process Status Changes
@cindex process sentinel
diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi
new file mode 100644
index 0000000..6237392
--- /dev/null
+++ b/doc/lispref/threads.texi
@@ -0,0 +1,252 @@
address@hidden -*-texinfo-*-
address@hidden This is part of the GNU Emacs Lisp Reference Manual.
address@hidden Copyright (C) 2012, 2013
address@hidden Free Software Foundation, Inc.
address@hidden See the file elisp.texi for copying conditions.
address@hidden Threads
address@hidden Threads
address@hidden threads
address@hidden concurrency
+
+ Emacs Lisp provides a limited form of concurrency, called
address@hidden All the threads in a given instance of Emacs share the
+same memory. Concurrency in Emacs Lisp is ``mostly cooperative'',
+meaning that Emacs will only switch execution between threads at
+well-defined times. However, the Emacs thread support has been
+designed in a way to later allow more fine-grained concurrency, and
+correct programs should not rely on cooperative threading.
+
+ Currently, thread switching will occur upon explicit request via
address@hidden, when waiting for keyboard input or for process
+output (e.g., during @code{accept-process-output}), or during blocking
+operations relating to threads, such as mutex locking or
address@hidden
+
+ Emacs Lisp provides primitives to create and control threads, and
+also to create and control mutexes and condition variables, useful for
+thread synchronization.
+
+ While global variables are shared among all Emacs Lisp threads,
+local variables are not---a dynamic @code{let} binding is local. Each
+thread also has its own current buffer (@pxref{Current Buffer}) and
+its own match data (@pxref{Match Data}).
+
+ Note that @code{let} bindings are treated specially by the Emacs
+Lisp implementation. There is no way to duplicate this unwinding and
+rewinding behavior other than by using @code{let}. For example, a
+manual implementation of @code{let} written using
address@hidden cannot arrange for variable values to be
+thread-specific.
+
+ In the case of lexical bindings (@pxref{Variable Scoping}), a
+closure is an object like any other in Emacs Lisp, and bindings in a
+closure are shared by any threads invoking the closure.
+
address@hidden
+* Basic Thread Functions:: Basic thread functions.
+* Mutexes:: Mutexes allow exclusive access to data.
+* Condition Variables:: Inter-thread events.
address@hidden menu
+
address@hidden Basic Thread Functions
address@hidden Basic Thread Functions
+
+ Threads can be created and waited for. A thread cannot be exited
+directly, but the current thread can be exited implicitly, and other
+threads can be signaled.
+
address@hidden make-thread function &optional name
+Create a new thread of execution which invokes @var{function}. When
address@hidden returns, the thread exits.
+
+The new thread is created with no local variable bindings in effect.
+The new thread's current buffer is inherited from the current thread.
+
address@hidden can be supplied to give a name to the thread. The name is
+used for debugging and informational purposes only; it has no meaning
+to Emacs. If @var{name} is provided, it must be a string.
+
+This function returns the new thread.
address@hidden defun
+
address@hidden threadp object
+This function returns @code{t} if @var{object} represents an Emacs
+thread, @code{nil} otherwise.
address@hidden defun
+
address@hidden thread-join thread
+Block until @var{thread} exits, or until the current thread is
+signaled. If @var{thread} has already exited, this returns
+immediately.
address@hidden defun
+
address@hidden thread-signal thread error-symbol data
+Like @code{signal} (@pxref{Signaling Errors}), but the signal is
+delivered in the thread @var{thread}. If @var{thread} is the current
+thread, then this just calls @code{signal} immediately.
address@hidden will cause a thread to exit a call to
address@hidden, @code{condition-wait}, or @code{thread-join}.
address@hidden defun
+
address@hidden thread-yield
+Yield execution to the next runnable thread.
address@hidden defun
+
address@hidden thread-name thread
+Return the name of @var{thread}, as specified to @code{make-thread}.
address@hidden defun
+
address@hidden thread-alive-p thread
+Return @code{t} if @var{thread} is alive, or @code{nil} if it is not.
+A thread is alive as long as its function is still executing.
address@hidden defun
+
address@hidden thread--blocker thread
+Return the object that @var{thread} is waiting on. This function is
+primarily intended for debugging, and is given a ``double hyphen''
+name to indicate that.
+
+If @var{thread} is blocked in @code{thread-join}, this returns the
+thread for which it is waiting.
+
+If @var{thread} is blocked in @code{mutex-lock}, this returns the mutex.
+
+If @var{thread} is blocked in @code{condition-wait}, this returns the
+condition variable.
+
+Otherwise, this returns @code{nil}.
address@hidden defun
+
address@hidden current-thread
+Return the current thread.
address@hidden defun
+
address@hidden all-threads
+Return a list of all the live thread objects. A new list is returned
+by each invocation.
address@hidden defun
+
address@hidden Mutexes
address@hidden Mutexes
+
+ A @dfn{mutex} is an exclusive lock. At any moment, zero or one
+threads may own a mutex. If a thread attempts to acquire a mutex, and
+the mutex is already owned by some other thread, then the acquiring
+thread will block until the mutex becomes available.
+
+ Emacs Lisp mutexes are of a type called @dfn{recursive}, which means
+that a thread can re-acquire a mutex it owns any number of times. A
+mutex keeps a count of how many times it has been acquired, and each
+acquisition of a mutex must be paired with a release. The last
+release by a thread of a mutex reverts it to the unowned state,
+potentially allowing another thread to acquire the mutex.
+
address@hidden mutexp object
+This function returns @code{t} if @var{object} represents an Emacs
+mutex, @code{nil} otherwise.
address@hidden defun
+
address@hidden make-mutex &optional name
+Create a new mutex and return it. If @var{name} is specified, it is a
+name given to the mutex. It must be a string. The name is for
+debugging purposes only; it has no meaning to Emacs.
address@hidden defun
+
address@hidden mutex-name mutex
+Return the name of @var{mutex}, as specified to @code{make-mutex}.
address@hidden defun
+
address@hidden mutex-lock mutex
+This will block until this thread acquires @var{mutex}, or until this
+thread is signaled using @code{thread-signal}. If @var{mutex} is
+already owned by this thread, this simply returns.
address@hidden defun
+
address@hidden mutex-unlock mutex
+Release @var{mutex}. If @var{mutex} is not owned by this thread, this
+will signal an error.
address@hidden defun
+
address@hidden with-mutex mutex address@hidden
+This macro is the simplest and safest way to evaluate forms while
+holding a mutex. It acquires @var{mutex}, invokes @var{body}, and
+then releases @var{mutex}. It returns the result of @var{body}.
address@hidden defmac
+
address@hidden Condition Variables
address@hidden Condition Variables
+
+ A @dfn{condition variable} is a way for a thread to block until some
+event occurs. A thread can wait on a condition variable, to be woken
+up when some other thread notifies the condition.
+
+ A condition variable is associated with a mutex and, conceptually,
+with some condition. For proper operation, the mutex must be
+acquired, and then a waiting thread must loop, testing the condition
+and waiting on the condition variable. For example:
+
address@hidden
+(with-mutex mutex
+ (while (not global-variable)
+ (condition-wait cond-var)))
address@hidden example
+
+ The mutex ensures atomicity, and the loop is for robustness---there
+may be spurious notifications.
+
+ Similarly, the mutex must be held before notifying the condition.
+The typical, and best, approach is to acquire the mutex, make the
+changes associated with this condition, and then notify it:
+
address@hidden
+(with-mutex mutex
+ (setq global-variable (some-computation))
+ (condition-notify cond-var))
address@hidden example
+
address@hidden make-condition-variable mutex &optional name
+Make a new condition variable associated with @var{mutex}. If
address@hidden is specified, it is a name given to the condition variable.
+It must be a string. The name is for debugging purposes only; it has
+no meaning to Emacs.
address@hidden defun
+
address@hidden condition-variable-p object
+This function returns @code{t} if @var{object} represents a condition
+variable, @code{nil} otherwise.
address@hidden defun
+
address@hidden condition-wait cond
+Wait for another thread to notify @var{cond}, a condition variable.
+This function will block until the condition is notified, or until a
+signal is delivered to this thread using @code{thread-signal}.
+
+It is an error to call @code{condition-wait} without holding the
+condition's associated mutex.
+
address@hidden releases the associated mutex while waiting.
+This allows other threads to acquire the mutex in order to notify the
+condition.
address@hidden defun
+
address@hidden condition-notify cond &optional all
+Notify @var{cond}. The mutex with @var{cond} must be held before
+calling this. Ordinarily a single waiting thread is woken by
address@hidden; but if @var{all} is not @code{nil}, then all
+threads waiting on @var{cond} are notified.
+
address@hidden releases the associated mutex while waiting.
+This allows other threads to acquire the mutex in order to wait on the
+condition.
address@hidden why bother?
address@hidden defun
+
address@hidden condition-name cond
+Return the name of @var{cond}, as passed to
address@hidden
address@hidden defun
+
address@hidden condition-mutex cond
+Return the mutex associated with @var{cond}. Note that the associated
+mutex cannot be changed.
address@hidden defun
diff --git a/etc/DEBUG b/etc/DEBUG
index 03efa3b..ddec7b4 100644
--- a/etc/DEBUG
+++ b/etc/DEBUG
@@ -313,7 +313,7 @@ type. Here are these commands:
xbufobjfwd xkbobjfwd xbuflocal xbuffer xsymbol xstring xvector xframe
xwinconfig xcompiled xcons xcar xcdr xsubr xprocess xfloat xscrollbar
xchartable xsubchartable xboolvector xhashtable xlist xcoding
- xcharset xfontset xfont
+ xcharset xfontset xfont xbytecode
Each one of them applies to a certain type or class of types.
(Some of these types are not visible in Lisp, because they exist only
diff --git a/etc/NEWS b/etc/NEWS
index 614b614..44de338 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -74,6 +74,19 @@ for '--daemon'.
* Changes in Emacs 26.1
+++
+** Emacs now provides a limited form of concurrency with Lisp threads.
+Concurrency in Emacs Lisp is "mostly cooperative", meaning that
+Emacs will only switch execution between threads at well-defined
+times: when Emacs waits for input, during blocking operations related
+to threads (such as mutex locking), or when the current thread
+explicitly yields. Global variables are shared among all threads, but
+a 'let' binding is thread-local. Each thread also has its own current
+buffer and its own match data.
+
+See the chapter "Threads" in the ELisp manual for full documentation
+of these facilities.
+
++++
** The new function 'file-name-case-insensitive-p' tests whether a
given file is on a case-insensitive filesystem.
diff --git a/lisp/subr.el b/lisp/subr.el
index 7d4409e..952453a 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -4953,6 +4953,20 @@ as a list.")
"-pkg.el"))
+;;; Thread support.
+
+(defmacro with-mutex (mutex &rest body)
+ "Invoke BODY with MUTEX held, releasing MUTEX when done.
+This is the simplest safe way to acquire and release a mutex."
+ (declare (indent 1) (debug t))
+ (let ((sym (make-symbol "mutex")))
+ `(let ((,sym ,mutex))
+ (mutex-lock ,sym)
+ (unwind-protect
+ (progn ,@body)
+ (mutex-unlock ,sym)))))
+
+
;;; Misc.
(defvar definition-prefixes (make-hash-table :test 'equal)
diff --git a/nt/inc/sys/socket.h b/nt/inc/sys/socket.h
index 6b9f56f..e9a021a 100644
--- a/nt/inc/sys/socket.h
+++ b/nt/inc/sys/socket.h
@@ -53,6 +53,7 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
#include <ws2tcpip.h>
/* process.c uses uint16_t (from C99) for IPv6, but
apparently it is not defined in some versions of mingw and msvc. */
+#include <stdint.h>
#ifndef UINT16_C
typedef unsigned short uint16_t;
#endif
diff --git a/src/.gdbinit b/src/.gdbinit
index b0c0dfd..9160ffa 100644
--- a/src/.gdbinit
+++ b/src/.gdbinit
@@ -1215,6 +1215,21 @@ document xwhichsymbols
maximum number of symbols referencing it to produce.
end
+define xbytecode
+ set $bt = byte_stack_list
+ while $bt
+ xgetptr $bt->byte_string
+ set $ptr = (struct Lisp_String *) $ptr
+ xprintbytestr $ptr
+ printf "\n0x%x => ", $bt->byte_string
+ xwhichsymbols $bt->byte_string 5
+ set $bt = $bt->next
+ end
+end
+document xbytecode
+ Print a backtrace of the byte code stack.
+end
+
# Show Lisp backtrace after normal backtrace.
define hookpost-backtrace
set $bt = backtrace_top ()
diff --git a/src/Makefile.in b/src/Makefile.in
index 7ca147f..ffc741d 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 \
doprnt.o intervals.o textprop.o composite.o xml.o $(NOTIFY_OBJ) \
$(XWIDGETS_OBJ) \
profiler.o decompress.o \
+ thread.o systhread.o \
$(if $(HYBRID_MALLOC),sheap.o) \
$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
$(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ)
diff --git a/src/alloc.c b/src/alloc.c
index 6eced7b..f2b7682 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -438,10 +438,6 @@ struct mem_node
enum mem_type type;
};
-/* Base address of stack. Set in main. */
-
-Lisp_Object *stack_base;
-
/* Root of the tree describing allocated Lisp memory. */
static struct mem_node *mem_root;
@@ -3190,8 +3186,7 @@ vector_nbytes (struct Lisp_Vector *v)
}
/* Release extra resources still in use by VECTOR, which may be any
- vector-like object. For now, this is used just to free data in
- font objects. */
+ vector-like object. */
static void
cleanup_vector (struct Lisp_Vector *vector)
@@ -3212,6 +3207,13 @@ cleanup_vector (struct Lisp_Vector *vector)
drv->close ((struct font *) vector);
}
}
+
+ if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
+ finalize_one_thread ((struct thread_state *) vector);
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
+ finalize_one_mutex ((struct Lisp_Mutex *) vector);
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
+ finalize_one_condvar ((struct Lisp_CondVar *) vector);
}
/* Reclaim space used by unmarked vectors. */
@@ -5047,14 +5049,13 @@ test_setjmp (void)
would be necessary, each one starting with one byte more offset
from the stack start. */
-static void
-mark_stack (void *end)
+void
+mark_stack (char *bottom, char *end)
{
-
/* This assumes that the stack is a contiguous region in memory. If
that's not the case, something has to be done here to iterate
over the stack segments. */
- mark_memory (stack_base, end);
+ mark_memory (bottom, end);
/* Allow for marking a secondary stack, like the register stack on the
ia64. */
@@ -5063,6 +5064,81 @@ mark_stack (void *end)
#endif
}
+/* This is a trampoline function that flushes registers to the stack,
+ and then calls FUNC. ARG is passed through to FUNC verbatim.
+
+ This function must be called whenever Emacs is about to release the
+ global interpreter lock. This lets the garbage collector easily
+ find roots in registers on threads that are not actively running
+ Lisp.
+
+ It is invalid to run any Lisp code or to allocate any GC memory
+ from FUNC. */
+
+void
+flush_stack_call_func (void (*func) (void *arg), void *arg)
+{
+ void *end;
+ struct thread_state *self = current_thread;
+
+#ifdef HAVE___BUILTIN_UNWIND_INIT
+ /* Force callee-saved registers and register windows onto the stack.
+ This is the preferred method if available, obviating the need for
+ machine dependent methods. */
+ __builtin_unwind_init ();
+ end = &end;
+#else /* not HAVE___BUILTIN_UNWIND_INIT */
+#ifndef GC_SAVE_REGISTERS_ON_STACK
+ /* jmp_buf may not be aligned enough on darwin-ppc64 */
+ union aligned_jmpbuf {
+ Lisp_Object o;
+ sys_jmp_buf j;
+ } j;
+ volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom;
+#endif
+ /* This trick flushes the register windows so that all the state of
+ the process is contained in the stack. */
+ /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
+ needed on ia64 too. See mach_dep.c, where it also says inline
+ assembler doesn't work with relevant proprietary compilers. */
+#ifdef __sparc__
+#if defined (__sparc64__) && defined (__FreeBSD__)
+ /* FreeBSD does not have a ta 3 handler. */
+ asm ("flushw");
+#else
+ asm ("ta 3");
+#endif
+#endif
+
+ /* Save registers that we need to see on the stack. We need to see
+ registers used to hold register variables and registers used to
+ pass parameters. */
+#ifdef GC_SAVE_REGISTERS_ON_STACK
+ GC_SAVE_REGISTERS_ON_STACK (end);
+#else /* not GC_SAVE_REGISTERS_ON_STACK */
+
+#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
+ setjmp will definitely work, test it
+ and print a message with the result
+ of the test. */
+ if (!setjmp_tested_p)
+ {
+ setjmp_tested_p = 1;
+ test_setjmp ();
+ }
+#endif /* GC_SETJMP_WORKS */
+
+ sys_setjmp (j.j);
+ end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
+#endif /* not GC_SAVE_REGISTERS_ON_STACK */
+#endif /* not HAVE___BUILTIN_UNWIND_INIT */
+
+ self->stack_top = end;
+ (*func) (arg);
+
+ eassert (current_thread == self);
+}
+
static bool
c_symbol_p (struct Lisp_Symbol *sym)
{
@@ -5768,24 +5844,14 @@ garbage_collect_1 (void *end)
mark_object (*staticvec[i]);
mark_pinned_symbols ();
- mark_specpdl ();
mark_terminals ();
mark_kboards ();
+ mark_threads ();
#ifdef USE_GTK
xg_mark_data ();
#endif
- mark_stack (end);
-
- {
- struct handler *handler;
- for (handler = handlerlist; handler; handler = handler->next)
- {
- mark_object (handler->tag_or_ch);
- mark_object (handler->val);
- }
- }
#ifdef HAVE_WINDOW_SYSTEM
mark_fringe_data ();
#endif
@@ -5817,6 +5883,8 @@ garbage_collect_1 (void *end)
gc_sweep ();
+ unmark_threads ();
+
/* Clear the mark bits that we set in certain root slots. */
VECTOR_UNMARK (&buffer_defaults);
VECTOR_UNMARK (&buffer_local_symbols);
diff --git a/src/buffer.c b/src/buffer.c
index 6815aa7..cea1ddb 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/>. */
#include "w32heap.h" /* for mmap_* */
#endif
-struct buffer *current_buffer; /* The current buffer. */
-
/* First buffer in chain of all buffers (in reverse order of creation).
Threaded through ->header.next.buffer. */
@@ -1654,6 +1652,9 @@ cleaning up all windows currently displaying the buffer
to be killed. */)
if (!BUFFER_LIVE_P (b))
return Qnil;
+ if (thread_check_current_buffer (b))
+ return Qnil;
+
/* Run hooks with the buffer to be killed the current buffer. */
{
ptrdiff_t count = SPECPDL_INDEX ();
diff --git a/src/buffer.h b/src/buffer.h
index 6ac161c..21ad5e3 100644
--- a/src/buffer.h
+++ b/src/buffer.h
@@ -1040,10 +1040,6 @@ extern struct buffer *all_buffers;
#define FOR_EACH_BUFFER(b) \
for ((b) = all_buffers; (b); (b) = (b)->next)
-/* This points to the current buffer. */
-
-extern struct buffer *current_buffer;
-
/* This structure holds the default values of the buffer-local variables
that have special slots in each buffer.
The default value occupies the same slot in this structure
diff --git a/src/bytecode.c b/src/bytecode.c
index 71ecdbf..c581ed6 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -280,10 +280,68 @@ enum byte_code_op
Bset_mark = 0163, /* this loser is no longer generated as of v18 */
#endif
};
+
+/* Whether to maintain a `top' and `bottom' field in the stack frame. */
+#define BYTE_MAINTAIN_TOP BYTE_CODE_SAFE
-/* Fetch the next byte from the bytecode stream. */
+/* Structure describing a value stack used during byte-code execution
+ in Fbyte_code. */
+
+struct byte_stack
+{
+ /* Program counter. This points into the byte_string below
+ and is relocated when that string is relocated. */
+ const unsigned char *pc;
+
+ /* Top and bottom of stack. The bottom points to an area of memory
+ allocated with alloca in Fbyte_code. */
+#if BYTE_MAINTAIN_TOP
+ Lisp_Object *top, *bottom;
+#endif
+
+ /* The string containing the byte-code, and its current address.
+ Storing this here protects it from GC because mark_byte_stack
+ marks it. */
+ Lisp_Object byte_string;
+ const unsigned char *byte_string_start;
+
+ /* Next entry in byte_stack_list. */
+ struct byte_stack *next;
+};
+
+/* A list of currently active byte-code execution value stacks.
+ Fbyte_code adds an entry to the head of this list before it starts
+ processing byte-code, and it removes the entry again when it is
+ done. Signaling an error truncates the list.
+
+ byte_stack_list is a macro defined in thread.h. */
+/* struct byte_stack *byte_stack_list; */
+
+
+/* Relocate program counters in the stacks on byte_stack_list. Called
+ when GC has completed. */
+
+void
+relocate_byte_stack (struct byte_stack *stack)
+{
+ for (; stack; stack = stack->next)
+ {
+ if (stack->byte_string_start != SDATA (stack->byte_string))
+ {
+ ptrdiff_t offset = stack->pc - stack->byte_string_start;
+ stack->byte_string_start = SDATA (stack->byte_string);
+ stack->pc = stack->byte_string_start + offset;
+ }
+ }
+}
-#define FETCH (*pc++)
+
+/* Fetch the next byte from the bytecode stream. */
+#ifdef BYTE_CODE_SAFE
+#define FETCH (eassert (stack.byte_string_start == SDATA (stack.byte_string)),
*stack.pc++)
+#else
+#define FETCH *stack.pc++
+#endif
/* Fetch two bytes from the bytecode stream and make a 16-bit number
out of them. */
@@ -308,6 +366,29 @@ enum byte_code_op
#define TOP (*top)
+#define CHECK_RANGE(ARG) \
+ (BYTE_CODE_SAFE && bytestr_length <= (ARG) ? emacs_abort () : (void) 0)
+
+/* A version of the QUIT macro which makes sure that the stack top is
+ set before signaling `quit'. */
+#define BYTE_CODE_QUIT \
+ do { \
+ if (quitcounter++) \
+ break; \
+ maybe_gc (); \
+ if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \
+ { \
+ Lisp_Object flag = Vquit_flag; \
+ Vquit_flag = Qnil; \
+ if (EQ (Vthrow_on_input, flag)) \
+ Fthrow (Vthrow_on_input, Qt); \
+ quit (); \
+ } \
+ else if (pending_signals) \
+ process_pending_signals (); \
+ } while (0)
+
+
DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
doc: /* Function used internally in byte-compiled code.
The 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,
ptrdiff_t bytestr_length = SBYTES (bytestr);
Lisp_Object *vectorp = XVECTOR (vector)->contents;
+ struct byte_stack stack;
- unsigned char quitcounter = 1;
+ stack.byte_string = bytestr;
+ stack.pc = stack.byte_string_start = SDATA (bytestr);
+ unsigned char quitcounter = 0;
EMACS_INT stack_items = XFASTINT (maxdepth) + 1;
USE_SAFE_ALLOCA;
Lisp_Object *stack_base;
- SAFE_ALLOCA_LISP_EXTRA (stack_base, stack_items, bytestr_length);
+ SAFE_ALLOCA_LISP (stack_base, stack_items);
Lisp_Object *stack_lim = stack_base + stack_items;
Lisp_Object *top = stack_base;
- memcpy (stack_lim, SDATA (bytestr), bytestr_length);
- void *void_stack_lim = stack_lim;
- unsigned char const *bytestr_data = void_stack_lim;
- unsigned char const *pc = bytestr_data;
+ stack.next = byte_stack_list;
+ byte_stack_list = &stack;
ptrdiff_t count = SPECPDL_INDEX ();
if (!NILP (args_template))
@@ -508,10 +590,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
CASE (Bgotoifnil):
{
- Lisp_Object v1 = POP;
+ Lisp_Object v1;
op = FETCH2;
+ v1 = POP;
if (NILP (v1))
- goto op_branch;
+ {
+ BYTE_CODE_QUIT;
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
+ }
NEXT;
}
@@ -569,7 +656,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
if (SYMBOLP (sym)
&& !EQ (val, Qunbound)
&& !XSYMBOL (sym)->redirect
- && !SYMBOL_TRAPPED_WRITE_P (sym))
+ && !SYMBOL_TRAPPED_WRITE_P (sym))
SET_SYMBOL_VAL (XSYMBOL (sym), val);
else
set_internal (sym, val, Qnil, SET_INTERNAL_SET);
@@ -666,72 +753,86 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
NEXT;
CASE (Bgoto):
- op = FETCH2;
- op_branch:
- op -= pc - bytestr_data;
- op_relative_branch:
- if (BYTE_CODE_SAFE
- && ! (bytestr_data - pc <= op
- && op < bytestr_data + bytestr_length - pc))
- emacs_abort ();
- quitcounter += op < 0;
- if (!quitcounter)
- {
- quitcounter = 1;
- maybe_gc ();
- QUIT;
- }
- pc += op;
+ BYTE_CODE_QUIT;
+ op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
NEXT;
CASE (Bgotoifnonnil):
op = FETCH2;
- if (!NILP (POP))
- goto op_branch;
+ Lisp_Object v1 = POP;
+ if (!NILP (v1))
+ {
+ BYTE_CODE_QUIT;
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
+ }
NEXT;
CASE (Bgotoifnilelsepop):
op = FETCH2;
if (NILP (TOP))
- goto op_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
+ }
+ else DISCARD (1);
NEXT;
CASE (Bgotoifnonnilelsepop):
op = FETCH2;
if (!NILP (TOP))
- goto op_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
+ }
+ else DISCARD (1);
NEXT;
CASE (BRgoto):
- op = FETCH - 128;
- goto op_relative_branch;
+ BYTE_CODE_QUIT;
+ stack.pc += (int) *stack.pc - 127;
+ NEXT;
CASE (BRgotoifnil):
- op = FETCH - 128;
if (NILP (POP))
- goto op_relative_branch;
+ {
+ BYTE_CODE_QUIT;
+ stack.pc += (int) *stack.pc - 128;
+ }
+ stack.pc++;
NEXT;
CASE (BRgotoifnonnil):
- op = FETCH - 128;
if (!NILP (POP))
- goto op_relative_branch;
+ {
+ BYTE_CODE_QUIT;
+ stack.pc += (int) *stack.pc - 128;
+ }
+ stack.pc++;
NEXT;
CASE (BRgotoifnilelsepop):
- op = FETCH - 128;
+ op = *stack.pc++;
if (NILP (TOP))
- goto op_relative_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ stack.pc += op - 128;
+ }
+ else DISCARD (1);
NEXT;
CASE (BRgotoifnonnilelsepop):
- op = FETCH - 128;
+ op = *stack.pc++;
if (!NILP (TOP))
- goto op_relative_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ stack.pc += op - 128;
+ }
+ else DISCARD (1);
NEXT;
CASE (Breturn):
@@ -791,11 +892,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
if (sys_setjmp (c->jmp))
{
struct handler *c = handlerlist;
+ int dest;
top = c->bytecode_top;
- op = c->bytecode_dest;
+ dest = c->bytecode_dest;
handlerlist = c->next;
PUSH (c->val);
- goto op_branch;
+ CHECK_RANGE (dest);
+ /* Might have been re-set by longjmp! */
+ stack.byte_string_start = SDATA (stack.byte_string);
+ stack.pc = stack.byte_string_start + dest;
}
NEXT;
@@ -1363,7 +1468,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
call3 (Qerror,
build_string ("Invalid byte opcode: op=%s, ptr=%d"),
make_number (op),
- make_number (pc - 1 - bytestr_data));
+ make_number (stack.pc - 1 - stack.byte_string_start));
/* Handy byte-codes for lexical binding. */
CASE (Bstack_ref1):
@@ -1423,6 +1528,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
exit:
+ byte_stack_list = byte_stack_list->next;
+
/* Binds and unbinds are supposed to be compiled balanced. */
if (SPECPDL_INDEX () != count)
{
diff --git a/src/data.c b/src/data.c
index 64cd8b2..09d94f5 100644
--- a/src/data.c
+++ b/src/data.c
@@ -258,6 +258,12 @@ for example, (type-of 1) returns `integer'. */)
return Qfont_entity;
if (FONT_OBJECT_P (object))
return Qfont_object;
+ if (THREADP (object))
+ return Qthread;
+ if (MUTEXP (object))
+ return Qmutex;
+ if (CONDVARP (object))
+ return Qcondition_variable;
return Qvector;
case Lisp_Float:
@@ -528,6 +534,33 @@ DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
return Qnil;
}
+DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a thread. */)
+ (Lisp_Object object)
+{
+ if (THREADP (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a mutex. */)
+ (Lisp_Object object)
+{
+ if (MUTEXP (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p,
+ 1, 1, 0,
+ doc: /* Return t if OBJECT is a condition variable. */)
+ (Lisp_Object object)
+{
+ if (CONDVARP (object))
+ return Qt;
+ return Qnil;
+}
/* Extract and set components of lists. */
@@ -3756,6 +3789,9 @@ syms_of_data (void)
DEFSYM (Qchar_table, "char-table");
DEFSYM (Qbool_vector, "bool-vector");
DEFSYM (Qhash_table, "hash-table");
+ DEFSYM (Qthread, "thread");
+ DEFSYM (Qmutex, "mutex");
+ DEFSYM (Qcondition_variable, "condition-variable");
DEFSYM (Qdefun, "defun");
@@ -3796,6 +3832,9 @@ syms_of_data (void)
defsubr (&Ssubrp);
defsubr (&Sbyte_code_function_p);
defsubr (&Schar_or_string_p);
+ defsubr (&Sthreadp);
+ defsubr (&Smutexp);
+ defsubr (&Scondition_variable_p);
defsubr (&Scar);
defsubr (&Scdr);
defsubr (&Scar_safe);
diff --git a/src/emacs.c b/src/emacs.c
index 75b2d6e..424ee05 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -155,10 +155,6 @@ bool running_asynch_code;
bool display_arg;
#endif
-/* An address near the bottom of the stack.
- Tells GC how to save a copy of the stack. */
-char *stack_bottom;
-
#if defined GNU_LINUX && !defined CANNOT_DUMP
/* The gap between BSS end and heap start as far as we can tell. */
static uprintmax_t heap_bss_diff;
@@ -670,7 +666,6 @@ close_output_streams (void)
int
main (int argc, char **argv)
{
- Lisp_Object dummy;
char stack_bottom_variable;
bool do_initial_setlocale;
bool dumping;
@@ -686,7 +681,8 @@ main (int argc, char **argv)
/* If we use --chdir, this records the original directory. */
char *original_pwd = 0;
- stack_base = &dummy;
+ /* Record (approximately) where the stack begins. */
+ stack_bottom = &stack_bottom_variable;
dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0
|| strcmp (argv[argc - 1], "bootstrap") == 0);
@@ -881,9 +877,6 @@ main (int argc, char **argv)
}
#endif /* HAVE_SETRLIMIT and RLIMIT_STACK and not CYGWIN */
- /* Record (approximately) where the stack begins. */
- stack_bottom = &stack_bottom_variable;
-
clearerr (stdin);
emacs_backtrace (-1);
@@ -1197,6 +1190,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
if (!initialized)
{
init_alloc_once ();
+ init_threads_once ();
init_obarray ();
init_eval_once ();
init_charset_once ();
@@ -1243,6 +1237,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
}
init_alloc ();
+ init_threads ();
if (do_initial_setlocale)
{
@@ -1585,6 +1580,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
#endif /* HAVE_W32NOTIFY */
#endif /* WINDOWSNT */
+ syms_of_threads ();
syms_of_profiler ();
keys_of_casefiddle ();
diff --git a/src/eval.c b/src/eval.c
index 8ad06dd..f1e0ae7 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/>. */
/* Chain of condition and catch handlers currently in effect. */
-struct handler *handlerlist;
+/* struct handler *handlerlist; */
/* Non-nil means record all fset's and provide's, to be undone
if the file being autoloaded is not fully loaded.
@@ -46,23 +46,25 @@ Lisp_Object Vautoload_queue;
is shutting down. */
Lisp_Object Vrun_hooks;
+/* The commented-out variables below are macros defined in thread.h. */
+
/* Current number of specbindings allocated in specpdl, not counting
the dummy entry specpdl[-1]. */
-ptrdiff_t specpdl_size;
+/* ptrdiff_t specpdl_size; */
/* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
only so that its address can be taken. */
-union specbinding *specpdl;
+/* union specbinding *specpdl; */
/* Pointer to first unused element in specpdl. */
-union specbinding *specpdl_ptr;
+/* union specbinding *specpdl_ptr; */
/* Depth in Lisp evaluations and function calls. */
-static EMACS_INT lisp_eval_depth;
+/* static EMACS_INT lisp_eval_depth; */
/* The value of num_nonmacro_input_events as of the last time we
started to enter the debugger. If we decide to enter the debugger
@@ -100,6 +102,13 @@ specpdl_symbol (union specbinding *pdl)
return pdl->let.symbol;
}
+static enum specbind_tag
+specpdl_kind (union specbinding *pdl)
+{
+ eassert (pdl->kind >= SPECPDL_LET);
+ return pdl->let.kind;
+}
+
static Lisp_Object
specpdl_old_value (union specbinding *pdl)
{
@@ -122,6 +131,13 @@ specpdl_where (union specbinding *pdl)
}
static Lisp_Object
+specpdl_saved_value (union specbinding *pdl)
+{
+ eassert (pdl->kind >= SPECPDL_LET);
+ return pdl->let.saved_value;
+}
+
+static Lisp_Object
specpdl_arg (union specbinding *pdl)
{
eassert (pdl->kind == SPECPDL_UNWIND);
@@ -218,20 +234,22 @@ init_eval_once (void)
Vrun_hooks = Qnil;
}
-static struct handler handlerlist_sentinel;
+/* static struct handler handlerlist_sentinel; */
void
init_eval (void)
{
+ byte_stack_list = 0;
specpdl_ptr = specpdl;
{ /* Put a dummy catcher at top-level so that handlerlist is never NULL.
This is important since handlerlist->nextfree holds the freelist
which would otherwise leak every time we unwind back to top-level. */
- handlerlist = handlerlist_sentinel.nextfree = &handlerlist_sentinel;
+ handlerlist_sentinel = xzalloc (sizeof (struct handler));
+ handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
struct handler *c = push_handler (Qunbound, CATCHER);
- eassert (c == &handlerlist_sentinel);
- handlerlist_sentinel.nextfree = NULL;
- handlerlist_sentinel.next = NULL;
+ eassert (c == handlerlist_sentinel);
+ handlerlist_sentinel->nextfree = NULL;
+ handlerlist_sentinel->next = NULL;
}
Vquit_flag = Qnil;
debug_on_next_call = 0;
@@ -1138,7 +1156,8 @@ unwind_to_catch (struct handler *catch, Lisp_Object value)
eassert (handlerlist == catch);
- lisp_eval_depth = catch->lisp_eval_depth;
+ byte_stack_list = catch->byte_stack;
+ lisp_eval_depth = catch->f_lisp_eval_depth;
sys_longjmp (catch->jmp, 1);
}
@@ -1428,10 +1447,11 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum
handlertype handlertype)
c->tag_or_ch = tag_ch_val;
c->val = Qnil;
c->next = handlerlist;
- c->lisp_eval_depth = lisp_eval_depth;
+ c->f_lisp_eval_depth = lisp_eval_depth;
c->pdlcount = SPECPDL_INDEX ();
c->poll_suppress_count = poll_suppress_count;
c->interrupt_input_blocked = interrupt_input_blocked;
+ c->byte_stack = byte_stack_list;
handlerlist = c;
return c;
}
@@ -1581,7 +1601,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object
data, bool keyboard_quit)
}
else
{
- if (handlerlist != &handlerlist_sentinel)
+ if (handlerlist != handlerlist_sentinel)
/* FIXME: This will come right back here if there's no `top-level'
catcher. A better solution would be to abort here, and instead
add a catch-all condition handler so we never come here. */
@@ -3175,6 +3195,36 @@ let_shadows_global_binding_p (Lisp_Object symbol)
return 0;
}
+static void
+do_specbind (struct Lisp_Symbol *sym, union specbinding *bind,
+ Lisp_Object value)
+{
+ switch (sym->redirect)
+ {
+ case SYMBOL_PLAINVAL:
+ if (!sym->trapped_write)
+ SET_SYMBOL_VAL (sym, value);
+ else
+ set_internal (specpdl_symbol (bind), value, Qnil, SET_INTERNAL_BIND);
+ break;
+
+ case SYMBOL_FORWARDED:
+ if (BUFFER_OBJFWDP (SYMBOL_FWD (sym))
+ && specpdl_kind (bind) == SPECPDL_LET_DEFAULT)
+ {
+ Fset_default (specpdl_symbol (bind), value);
+ return;
+ }
+ /* FALLTHROUGH */
+ case SYMBOL_LOCALIZED:
+ set_internal (specpdl_symbol (bind), value, Qnil, SET_INTERNAL_BIND);
+ break;
+
+ default:
+ emacs_abort ();
+ }
+}
+
/* `specpdl_ptr' describes which variable is
let-bound, so it can be properly undone when we unbind_to.
It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
@@ -3206,11 +3256,9 @@ specbind (Lisp_Object symbol, Lisp_Object value)
specpdl_ptr->let.kind = SPECPDL_LET;
specpdl_ptr->let.symbol = symbol;
specpdl_ptr->let.old_value = SYMBOL_VAL (sym);
+ specpdl_ptr->let.saved_value = Qnil;
grow_specpdl ();
- if (!sym->trapped_write)
- SET_SYMBOL_VAL (sym, value);
- else
- set_internal (symbol, value, Qnil, SET_INTERNAL_BIND);
+ do_specbind (sym, specpdl_ptr - 1, value);
break;
case SYMBOL_LOCALIZED:
if (SYMBOL_BLV (sym)->frame_local)
@@ -3222,6 +3270,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
specpdl_ptr->let.symbol = symbol;
specpdl_ptr->let.old_value = ovalue;
specpdl_ptr->let.where = Fcurrent_buffer ();
+ specpdl_ptr->let.saved_value = Qnil;
eassert (sym->redirect != SYMBOL_LOCALIZED
|| (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
@@ -3242,7 +3291,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
{
specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
grow_specpdl ();
- Fset_default (symbol, value);
+ do_specbind (sym, specpdl_ptr - 1, value);
return;
}
}
@@ -3250,7 +3299,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
specpdl_ptr->let.kind = SPECPDL_LET;
grow_specpdl ();
- set_internal (symbol, value, Qnil, SET_INTERNAL_BIND);
+ do_specbind (sym, specpdl_ptr - 1, value);
break;
}
default: emacs_abort ();
@@ -3294,6 +3343,91 @@ record_unwind_protect_void (void (*function) (void))
grow_specpdl ();
}
+void
+rebind_for_thread_switch (void)
+{
+ union specbinding *bind;
+
+ for (bind = specpdl; bind != specpdl_ptr; ++bind)
+ {
+ if (bind->kind >= SPECPDL_LET)
+ {
+ Lisp_Object value = specpdl_saved_value (bind);
+ Lisp_Object sym = specpdl_symbol (bind);
+ bool was_trapped =
+ SYMBOLP (sym)
+ && XSYMBOL (sym)->trapped_write == SYMBOL_TRAPPED_WRITE;
+ /* FIXME: This is not clean, and if do_specbind signals an
+ error, the symbol will be left untrapped. */
+ if (was_trapped)
+ XSYMBOL (sym)->trapped_write = SYMBOL_UNTRAPPED_WRITE;
+ bind->let.saved_value = Qnil;
+ do_specbind (XSYMBOL (sym), bind, value);
+ if (was_trapped)
+ XSYMBOL (sym)->trapped_write = SYMBOL_TRAPPED_WRITE;
+ }
+ }
+}
+
+static void
+do_one_unbind (union specbinding *this_binding, bool unwinding)
+{
+ eassert (unwinding || this_binding->kind >= SPECPDL_LET);
+ switch (this_binding->kind)
+ {
+ case SPECPDL_UNWIND:
+ this_binding->unwind.func (this_binding->unwind.arg);
+ break;
+ case SPECPDL_UNWIND_PTR:
+ this_binding->unwind_ptr.func (this_binding->unwind_ptr.arg);
+ break;
+ case SPECPDL_UNWIND_INT:
+ this_binding->unwind_int.func (this_binding->unwind_int.arg);
+ break;
+ case SPECPDL_UNWIND_VOID:
+ this_binding->unwind_void.func ();
+ break;
+ case SPECPDL_BACKTRACE:
+ break;
+ case SPECPDL_LET:
+ { /* If variable has a trivial value (no forwarding), and isn't
+ trapped, we can just set it. */
+ Lisp_Object sym = specpdl_symbol (this_binding);
+ if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL)
+ {
+ if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE)
+ SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value (this_binding));
+ else
+ set_internal (sym, specpdl_old_value (this_binding),
+ Qnil, SET_INTERNAL_UNBIND);
+ break;
+ }
+ else
+ { /* FALLTHROUGH!!
+ NOTE: we only ever come here if make_local_foo was used for
+ the first time on this var within this let. */
+ }
+ }
+ case SPECPDL_LET_DEFAULT:
+ Fset_default (specpdl_symbol (this_binding),
+ specpdl_old_value (this_binding));
+ break;
+ case SPECPDL_LET_LOCAL:
+ {
+ Lisp_Object symbol = specpdl_symbol (this_binding);
+ Lisp_Object where = specpdl_where (this_binding);
+ Lisp_Object old_value = specpdl_old_value (this_binding);
+ eassert (BUFFERP (where));
+
+ /* If this was a local binding, reset the value in the appropriate
+ buffer, but only if that buffer's binding still exists. */
+ if (!NILP (Flocal_variable_p (symbol, where)))
+ set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND);
+ }
+ break;
+ }
+}
+
static void
do_nothing (void)
{}
@@ -3353,66 +3487,16 @@ unbind_to (ptrdiff_t count, Lisp_Object value)
while (specpdl_ptr != specpdl + count)
{
- /* Decrement specpdl_ptr before we do the work to unbind it, so
- that an error in unbinding won't try to unbind the same entry
- again. Take care to copy any parts of the binding needed
- before invoking any code that can make more bindings. */
+ /* Copy the binding, and decrement specpdl_ptr, before we do
+ the work to unbind it. We decrement first
+ so that an error in unbinding won't try to unbind
+ the same entry again, and we copy the binding first
+ in case more bindings are made during some of the code we run. */
- specpdl_ptr--;
-
- switch (specpdl_ptr->kind)
- {
- case SPECPDL_UNWIND:
- specpdl_ptr->unwind.func (specpdl_ptr->unwind.arg);
- break;
- case SPECPDL_UNWIND_PTR:
- specpdl_ptr->unwind_ptr.func (specpdl_ptr->unwind_ptr.arg);
- break;
- case SPECPDL_UNWIND_INT:
- specpdl_ptr->unwind_int.func (specpdl_ptr->unwind_int.arg);
- break;
- case SPECPDL_UNWIND_VOID:
- specpdl_ptr->unwind_void.func ();
- break;
- case SPECPDL_BACKTRACE:
- break;
- case SPECPDL_LET:
- { /* If variable has a trivial value (no forwarding), and
- isn't trapped, we can just set it. */
- Lisp_Object sym = specpdl_symbol (specpdl_ptr);
- if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL)
- {
- if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE)
- SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value
(specpdl_ptr));
- else
- set_internal (sym, specpdl_old_value (specpdl_ptr),
- Qnil, SET_INTERNAL_UNBIND);
- break;
- }
- else
- { /* FALLTHROUGH!!
- NOTE: we only ever come here if make_local_foo was used for
- the first time on this var within this let. */
- }
- }
- case SPECPDL_LET_DEFAULT:
- Fset_default (specpdl_symbol (specpdl_ptr),
- specpdl_old_value (specpdl_ptr));
- break;
- case SPECPDL_LET_LOCAL:
- {
- Lisp_Object symbol = specpdl_symbol (specpdl_ptr);
- Lisp_Object where = specpdl_where (specpdl_ptr);
- Lisp_Object old_value = specpdl_old_value (specpdl_ptr);
- eassert (BUFFERP (where));
+ union specbinding this_binding;
+ this_binding = *--specpdl_ptr;
- /* If this was a local binding, reset the value in the appropriate
- buffer, but only if that buffer's binding still exists. */
- if (!NILP (Flocal_variable_p (symbol, where)))
- set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND);
- }
- break;
- }
+ do_one_unbind (&this_binding, true);
}
if (NILP (Vquit_flag) && !NILP (quitf))
@@ -3421,6 +3505,31 @@ unbind_to (ptrdiff_t count, Lisp_Object value)
return value;
}
+void
+unbind_for_thread_switch (struct thread_state *thr)
+{
+ union specbinding *bind;
+
+ for (bind = thr->m_specpdl_ptr; bind > thr->m_specpdl;)
+ {
+ if ((--bind)->kind >= SPECPDL_LET)
+ {
+ Lisp_Object sym = specpdl_symbol (bind);
+ bool was_trapped =
+ SYMBOLP (sym)
+ && XSYMBOL (sym)->trapped_write == SYMBOL_TRAPPED_WRITE;
+ bind->let.saved_value = find_symbol_value (sym);
+ /* FIXME: This is not clean, and if do_one_unbind signals an
+ error, the symbol will be left untrapped. */
+ if (was_trapped)
+ XSYMBOL (sym)->trapped_write = SYMBOL_UNTRAPPED_WRITE;
+ do_one_unbind (bind, false);
+ if (was_trapped)
+ XSYMBOL (sym)->trapped_write = SYMBOL_TRAPPED_WRITE;
+ }
+ }
+}
+
DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
doc: /* Return non-nil if SYMBOL's global binding has been declared
special.
A special variable is one that will be bound dynamically, even in a
@@ -3743,10 +3852,10 @@ NFRAMES and BASE specify the activation frame to use,
as in `backtrace-frame'.
void
-mark_specpdl (void)
+mark_specpdl (union specbinding *first, union specbinding *ptr)
{
union specbinding *pdl;
- for (pdl = specpdl; pdl != specpdl_ptr; pdl++)
+ for (pdl = first; pdl != ptr; pdl++)
{
switch (pdl->kind)
{
@@ -3772,6 +3881,7 @@ mark_specpdl (void)
case SPECPDL_LET:
mark_object (specpdl_symbol (pdl));
mark_object (specpdl_old_value (pdl));
+ mark_object (specpdl_saved_value (pdl));
break;
case SPECPDL_UNWIND_PTR:
diff --git a/src/lisp.h b/src/lisp.h
index 11e49b6..252707c 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/>. */
#include <intprops.h>
#include <verify.h>
+#include "systhread.h"
+
INLINE_HEADER_BEGIN
/* Define a TYPE constant ID as an externally visible name. Use like this:
@@ -588,6 +590,9 @@ INLINE bool (SYMBOLP) (Lisp_Object);
INLINE bool (VECTORLIKEP) (Lisp_Object);
INLINE bool WINDOWP (Lisp_Object);
INLINE bool TERMINALP (Lisp_Object);
+INLINE bool THREADP (Lisp_Object);
+INLINE bool MUTEXP (Lisp_Object);
+INLINE bool CONDVARP (Lisp_Object);
INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object);
INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object);
INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object);
@@ -756,6 +761,39 @@ struct Lisp_Symbol
#include "globals.h"
+/* Header of vector-like objects. This documents the layout constraints on
+ vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
+ compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
+ and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
+ because when two such pointers potentially alias, a compiler won't
+ incorrectly reorder loads and stores to their size fields. See
+ Bug#8546. */
+struct vectorlike_header
+ {
+ /* The only field contains various pieces of information:
+ - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
+ - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
+ vector (0) or a pseudovector (1).
+ - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
+ of slots) of the vector.
+ - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
+ - a) pseudovector subtype held in PVEC_TYPE_MASK field;
+ - b) number of Lisp_Objects slots at the beginning of the object
+ held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
+ traced by the GC;
+ - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
+ measured in word_size units. Rest fields may also include
+ Lisp_Objects, but these objects usually needs some special treatment
+ during GC.
+ There are some exceptions. For PVEC_FREE, b) is always zero. For
+ PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
+ Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
+ 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
+ ptrdiff_t size;
+ };
+
+#include "thread.h"
+
/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa.
At the machine level, these operations are no-ops. */
@@ -802,6 +840,9 @@ enum pvec_type
PVEC_OTHER,
PVEC_XWIDGET,
PVEC_XWIDGET_VIEW,
+ PVEC_THREAD,
+ PVEC_MUTEX,
+ PVEC_CONDVAR,
/* These should be last, check internal_equal to see why. */
PVEC_COMPILED,
@@ -1105,6 +1146,27 @@ XBOOL_VECTOR (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike);
}
+INLINE struct thread_state *
+XTHREAD (Lisp_Object a)
+{
+ eassert (THREADP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+}
+
+INLINE struct Lisp_Mutex *
+XMUTEX (Lisp_Object a)
+{
+ eassert (MUTEXP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+}
+
+INLINE struct Lisp_CondVar *
+XCONDVAR (Lisp_Object a)
+{
+ eassert (CONDVARP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+}
+
/* Construct a Lisp_Object from a value or address. */
INLINE Lisp_Object
@@ -1171,6 +1233,9 @@ builtin_lisp_symbol (int index)
#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
#define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE))
+#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD))
+#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX))
+#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR))
/* Efficiently convert a pointer to a Lisp object and back. The
pointer is represented as a Lisp integer, so the garbage collector
@@ -1402,37 +1467,6 @@ STRING_SET_CHARS (Lisp_Object string, ptrdiff_t newsize)
XSTRING (string)->size = newsize;
}
-/* Header of vector-like objects. This documents the layout constraints on
- vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
- compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
- and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
- because when two such pointers potentially alias, a compiler won't
- incorrectly reorder loads and stores to their size fields. See
- Bug#8546. */
-struct vectorlike_header
- {
- /* The only field contains various pieces of information:
- - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
- - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
- vector (0) or a pseudovector (1).
- - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
- of slots) of the vector.
- - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
- - a) pseudovector subtype held in PVEC_TYPE_MASK field;
- - b) number of Lisp_Objects slots at the beginning of the object
- held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
- traced by the GC;
- - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
- measured in word_size units. Rest fields may also include
- Lisp_Objects, but these objects usually needs some special treatment
- during GC.
- There are some exceptions. For PVEC_FREE, b) is always zero. For
- PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
- Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
- 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
- ptrdiff_t size;
- };
-
/* A regular vector is just a header plus an array of Lisp_Objects. */
struct Lisp_Vector
@@ -2782,6 +2816,24 @@ FRAMEP (Lisp_Object a)
return PSEUDOVECTORP (a, PVEC_FRAME);
}
+INLINE bool
+THREADP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_THREAD);
+}
+
+INLINE bool
+MUTEXP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_MUTEX);
+}
+
+INLINE bool
+CONDVARP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_CONDVAR);
+}
+
/* Test for image (image . spec) */
INLINE bool
IMAGEP (Lisp_Object x)
@@ -2930,6 +2982,25 @@ CHECK_NUMBER_OR_FLOAT (Lisp_Object x)
CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x);
\
} while (false)
+
+INLINE void
+CHECK_THREAD (Lisp_Object x)
+{
+ CHECK_TYPE (THREADP (x), Qthreadp, x);
+}
+
+INLINE void
+CHECK_MUTEX (Lisp_Object x)
+{
+ CHECK_TYPE (MUTEXP (x), Qmutexp, x);
+}
+
+INLINE void
+CHECK_CONDVAR (Lisp_Object x)
+{
+ CHECK_TYPE (CONDVARP (x), Qcondition_variable_p, x);
+}
+
/* Since we can't assign directly to the CAR or CDR fields of a cons
cell, use these when checking that those fields contain numbers. */
INLINE void
@@ -3141,6 +3212,9 @@ union specbinding
ENUM_BF (specbind_tag) kind : CHAR_BIT;
/* `where' is not used in the case of SPECPDL_LET. */
Lisp_Object symbol, old_value, where;
+ /* Normally this is unused; but it is set to the symbol's
+ current value when a thread is swapped out. */
+ Lisp_Object saved_value;
} let;
struct {
ENUM_BF (specbind_tag) kind : CHAR_BIT;
@@ -3151,9 +3225,10 @@ union specbinding
} bt;
};
-extern union specbinding *specpdl;
-extern union specbinding *specpdl_ptr;
-extern ptrdiff_t specpdl_size;
+/* These 3 are defined as macros in thread.h. */
+/* extern union specbinding *specpdl; */
+/* extern union specbinding *specpdl_ptr; */
+/* extern ptrdiff_t specpdl_size; */
INLINE ptrdiff_t
SPECPDL_INDEX (void)
@@ -3204,18 +3279,15 @@ struct handler
/* Most global vars are reset to their value via the specpdl mechanism,
but a few others are handled by storing their value here. */
sys_jmp_buf jmp;
- EMACS_INT lisp_eval_depth;
+ EMACS_INT f_lisp_eval_depth;
ptrdiff_t pdlcount;
int poll_suppress_count;
int interrupt_input_blocked;
+ struct byte_stack *byte_stack;
};
extern Lisp_Object memory_signal_data;
-/* An address near the bottom of the stack.
- Tells GC how to save a copy of the stack. */
-extern char *stack_bottom;
-
/* Check quit-flag and quit if it is non-nil.
Typing C-g does not directly cause a quit; it only sets Vquit_flag.
So the program needs to do QUIT at times when it is safe to quit.
@@ -3617,9 +3689,10 @@ extern void refill_memory_reserve (void);
#endif
extern void alloc_unexec_pre (void);
extern void alloc_unexec_post (void);
+extern void mark_stack (char *, char *);
+extern void flush_stack_call_func (void (*func) (void *arg), void *arg);
extern const char *pending_malloc_warning;
extern Lisp_Object zero_vector;
-extern Lisp_Object *stack_base;
extern EMACS_INT consing_since_gc;
extern EMACS_INT gc_relative_threshold;
extern EMACS_INT memory_full_cons_threshold;
@@ -3881,7 +3954,6 @@ extern Lisp_Object Vautoload_queue;
extern Lisp_Object Vrun_hooks;
extern Lisp_Object Vsignaling_function;
extern Lisp_Object inhibit_lisp_code;
-extern struct handler *handlerlist;
/* To run a normal hook, use the appropriate function from the list below.
The calling convention:
@@ -3939,6 +4011,8 @@ extern void clear_unwind_protect (ptrdiff_t);
extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object),
Lisp_Object);
extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *);
extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object);
+extern void rebind_for_thread_switch (void);
+extern void unbind_for_thread_switch (struct thread_state *);
extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
extern _Noreturn void verror (const char *, va_list)
ATTRIBUTE_FORMAT_PRINTF (1, 0);
@@ -3955,7 +4029,7 @@ extern void init_eval (void);
extern void syms_of_eval (void);
extern void unwind_body (Lisp_Object);
extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t);
-extern void mark_specpdl (void);
+extern void mark_specpdl (union specbinding *first, union specbinding *ptr);
extern void get_backtrace (Lisp_Object array);
Lisp_Object backtrace_top_function (void);
extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
@@ -3970,6 +4044,9 @@ extern void module_init (void);
extern void syms_of_module (void);
#endif
+/* Defined in thread.c. */
+extern void mark_threads (void);
+
/* Defined in editfns.c. */
extern void insert1 (Lisp_Object);
extern Lisp_Object save_excursion_save (void);
@@ -4250,6 +4327,7 @@ extern int read_bytecode_char (bool);
/* Defined in bytecode.c. */
extern void syms_of_bytecode (void);
+extern void relocate_byte_stack (struct byte_stack *);
extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, ptrdiff_t, Lisp_Object *);
extern Lisp_Object get_byte_code_arity (Lisp_Object);
diff --git a/src/print.c b/src/print.c
index f3db674..6c350fc 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1911,6 +1911,42 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
}
printchar ('>', printcharfun);
}
+ else if (THREADP (obj))
+ {
+ print_c_string ("#<thread ", printcharfun);
+ if (STRINGP (XTHREAD (obj)->name))
+ print_string (XTHREAD (obj)->name, printcharfun);
+ else
+ {
+ int len = sprintf (buf, "%p", XTHREAD (obj));
+ strout (buf, len, len, printcharfun);
+ }
+ printchar ('>', printcharfun);
+ }
+ else if (MUTEXP (obj))
+ {
+ print_c_string ("#<mutex ", printcharfun);
+ if (STRINGP (XMUTEX (obj)->name))
+ print_string (XMUTEX (obj)->name, printcharfun);
+ else
+ {
+ int len = sprintf (buf, "%p", XMUTEX (obj));
+ strout (buf, len, len, printcharfun);
+ }
+ printchar ('>', printcharfun);
+ }
+ else if (CONDVARP (obj))
+ {
+ print_c_string ("#<condvar ", printcharfun);
+ if (STRINGP (XCONDVAR (obj)->name))
+ print_string (XCONDVAR (obj)->name, printcharfun);
+ else
+ {
+ int len = sprintf (buf, "%p", XCONDVAR (obj));
+ strout (buf, len, len, printcharfun);
+ }
+ printchar ('>', printcharfun);
+ }
else
{
ptrdiff_t size = ASIZE (obj);
diff --git a/src/process.c b/src/process.c
index 8ab73bd..31c9d74 100644
--- a/src/process.c
+++ b/src/process.c
@@ -138,7 +138,7 @@ static struct rlimit nofile_limit;
#ifdef WINDOWSNT
extern int sys_select (int, fd_set *, fd_set *, fd_set *,
- struct timespec *, void *);
+ const struct timespec *, const sigset_t *);
#endif
/* Work around GCC 4.3.0 bug with strict overflow checking; see
@@ -260,36 +260,11 @@ static int read_process_output (Lisp_Object, int);
static void create_pty (Lisp_Object);
static void exec_sentinel (Lisp_Object, Lisp_Object);
-/* Mask of bits indicating the descriptors that we wait for input on. */
-
-static fd_set input_wait_mask;
-
-/* Mask that excludes keyboard input descriptor(s). */
-
-static fd_set non_keyboard_wait_mask;
-
-/* Mask that excludes process input descriptor(s). */
-
-static fd_set non_process_wait_mask;
-
-/* Mask for selecting for write. */
-
-static fd_set write_mask;
-
-/* Mask of bits indicating the descriptors that we wait for connect to
- complete on. Once they complete, they are removed from this mask
- and added to the input_wait_mask and non_keyboard_wait_mask. */
-
-static fd_set connect_wait_mask;
-
/* Number of bits set in connect_wait_mask. */
static int num_pending_connects;
-/* The largest descriptor currently in use for a process object; -1 if none.
*/
-static int max_process_desc;
-
-/* The largest descriptor currently in use for input; -1 if none. */
-static int max_input_desc;
+/* The largest descriptor currently in use; -1 if none. */
+static int max_desc;
/* Set the external socket descriptor for Emacs to use when
`make-network-process' is called with a non-nil
@@ -384,6 +359,11 @@ pset_mark (struct Lisp_Process *p, Lisp_Object val)
p->mark = val;
}
static void
+pset_thread (struct Lisp_Process *p, Lisp_Object val)
+{
+ p->thread = val;
+}
+static void
pset_name (struct Lisp_Process *p, Lisp_Object val)
{
p->name = val;
@@ -426,13 +406,34 @@ make_lisp_proc (struct Lisp_Process *p)
return make_lisp_ptr (p, Lisp_Vectorlike);
}
+enum fd_bits
+{
+ /* Read from file descriptor. */
+ FOR_READ = 1,
+ /* Write to file descriptor. */
+ FOR_WRITE = 2,
+ /* This descriptor refers to a keyboard. Only valid if FOR_READ is
+ set. */
+ KEYBOARD_FD = 4,
+ /* This descriptor refers to a process. */
+ PROCESS_FD = 8,
+ /* A non-blocking connect. Only valid if FOR_WRITE is set. */
+ NON_BLOCKING_CONNECT_FD = 16
+};
+
static struct fd_callback_data
{
fd_callback func;
void *data;
-#define FOR_READ 1
-#define FOR_WRITE 2
- int condition; /* Mask of the defines above. */
+ /* Flags from enum fd_bits. */
+ int flags;
+ /* If this fd is locked to a certain thread, this points to it.
+ Otherwise, this is NULL. If an fd is locked to a thread, then
+ only that thread is permitted to wait on it. */
+ struct thread_state *thread;
+ /* If this fd is currently being selected on by a thread, this
+ points to the thread. Otherwise it is NULL. */
+ struct thread_state *waiting_thread;
} fd_callback_info[FD_SETSIZE];
@@ -446,7 +447,25 @@ add_read_fd (int fd, fd_callback func, void *data)
fd_callback_info[fd].func = func;
fd_callback_info[fd].data = data;
- fd_callback_info[fd].condition |= FOR_READ;
+}
+
+static void
+add_non_keyboard_read_fd (int fd)
+{
+ eassert (fd >= 0 && fd < FD_SETSIZE);
+ eassert (fd_callback_info[fd].func == NULL);
+
+ fd_callback_info[fd].flags &= ~KEYBOARD_FD;
+ fd_callback_info[fd].flags |= FOR_READ;
+ if (fd > max_desc)
+ max_desc = fd;
+}
+
+static void
+add_process_read_fd (int fd)
+{
+ add_non_keyboard_read_fd (fd);
+ fd_callback_info[fd].flags |= PROCESS_FD;
}
/* Stop monitoring file descriptor FD for when read is possible. */
@@ -456,8 +475,7 @@ delete_read_fd (int fd)
{
delete_keyboard_wait_descriptor (fd);
- fd_callback_info[fd].condition &= ~FOR_READ;
- if (fd_callback_info[fd].condition == 0)
+ if (fd_callback_info[fd].flags == 0)
{
fd_callback_info[fd].func = 0;
fd_callback_info[fd].data = 0;
@@ -470,28 +488,39 @@ delete_read_fd (int fd)
void
add_write_fd (int fd, fd_callback func, void *data)
{
- FD_SET (fd, &write_mask);
- if (fd > max_input_desc)
- max_input_desc = fd;
+ eassert (fd >= 0 && fd < FD_SETSIZE);
fd_callback_info[fd].func = func;
fd_callback_info[fd].data = data;
- fd_callback_info[fd].condition |= FOR_WRITE;
+ fd_callback_info[fd].flags |= FOR_WRITE;
+ if (fd > max_desc)
+ max_desc = fd;
}
-/* FD is no longer an input descriptor; update max_input_desc accordingly. */
+static void
+add_non_blocking_write_fd (int fd)
+{
+ eassert (fd >= 0 && fd < FD_SETSIZE);
+ eassert (fd_callback_info[fd].func == NULL);
+
+ fd_callback_info[fd].flags |= FOR_WRITE | NON_BLOCKING_CONNECT_FD;
+ if (fd > max_desc)
+ max_desc = fd;
+ ++num_pending_connects;
+}
static void
-delete_input_desc (int fd)
+recompute_max_desc (void)
{
- if (fd == max_input_desc)
- {
- do
- fd--;
- while (0 <= fd && ! (FD_ISSET (fd, &input_wait_mask)
- || FD_ISSET (fd, &write_mask)));
+ int fd;
- max_input_desc = fd;
+ for (fd = max_desc; fd >= 0; --fd)
+ {
+ if (fd_callback_info[fd].flags != 0)
+ {
+ max_desc = fd;
+ break;
+ }
}
}
@@ -500,13 +529,121 @@ delete_input_desc (int fd)
void
delete_write_fd (int fd)
{
- FD_CLR (fd, &write_mask);
- fd_callback_info[fd].condition &= ~FOR_WRITE;
- if (fd_callback_info[fd].condition == 0)
+ if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0)
+ {
+ if (--num_pending_connects < 0)
+ emacs_abort ();
+ }
+ fd_callback_info[fd].flags &= ~(FOR_WRITE | NON_BLOCKING_CONNECT_FD);
+ if (fd_callback_info[fd].flags == 0)
{
fd_callback_info[fd].func = 0;
fd_callback_info[fd].data = 0;
- delete_input_desc (fd);
+
+ if (fd == max_desc)
+ recompute_max_desc ();
+ }
+}
+
+static void
+compute_input_wait_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_desc; ++fd)
+ {
+ if (fd_callback_info[fd].thread != NULL
+ && fd_callback_info[fd].thread != current_thread)
+ continue;
+ if (fd_callback_info[fd].waiting_thread != NULL
+ && fd_callback_info[fd].waiting_thread != current_thread)
+ continue;
+ if ((fd_callback_info[fd].flags & FOR_READ) != 0)
+ {
+ FD_SET (fd, mask);
+ fd_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
+compute_non_process_wait_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_desc; ++fd)
+ {
+ if (fd_callback_info[fd].thread != NULL
+ && fd_callback_info[fd].thread != current_thread)
+ continue;
+ if (fd_callback_info[fd].waiting_thread != NULL
+ && fd_callback_info[fd].waiting_thread != current_thread)
+ continue;
+ if ((fd_callback_info[fd].flags & FOR_READ) != 0
+ && (fd_callback_info[fd].flags & PROCESS_FD) == 0)
+ {
+ FD_SET (fd, mask);
+ fd_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
+compute_non_keyboard_wait_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_desc; ++fd)
+ {
+ if (fd_callback_info[fd].thread != NULL
+ && fd_callback_info[fd].thread != current_thread)
+ continue;
+ if (fd_callback_info[fd].waiting_thread != NULL
+ && fd_callback_info[fd].waiting_thread != current_thread)
+ continue;
+ if ((fd_callback_info[fd].flags & FOR_READ) != 0
+ && (fd_callback_info[fd].flags & KEYBOARD_FD) == 0)
+ {
+ FD_SET (fd, mask);
+ fd_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
+compute_write_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_desc; ++fd)
+ {
+ if (fd_callback_info[fd].thread != NULL
+ && fd_callback_info[fd].thread != current_thread)
+ continue;
+ if (fd_callback_info[fd].waiting_thread != NULL
+ && fd_callback_info[fd].waiting_thread != current_thread)
+ continue;
+ if ((fd_callback_info[fd].flags & FOR_WRITE) != 0)
+ {
+ FD_SET (fd, mask);
+ fd_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
+clear_waiting_thread_info (void)
+{
+ int fd;
+
+ for (fd = 0; fd <= max_desc; ++fd)
+ {
+ if (fd_callback_info[fd].waiting_thread == current_thread)
+ fd_callback_info[fd].waiting_thread = NULL;
}
}
@@ -716,6 +853,7 @@ make_process (Lisp_Object name)
Lisp data to nil, so do it only for slots which should not be nil. */
pset_status (p, Qrun);
pset_mark (p, Fmake_marker ());
+ pset_thread (p, Fcurrent_thread ());
/* Initialize non-Lisp data. Note that allocate_process zeroes out all
non-Lisp data, so do it only for slots which should not be zero. */
@@ -764,6 +902,27 @@ remove_process (register Lisp_Object proc)
deactivate_process (proc);
}
+void
+update_processes_for_thread_death (Lisp_Object dying_thread)
+{
+ Lisp_Object pair;
+
+ for (pair = Vprocess_alist; !NILP (pair); pair = XCDR (pair))
+ {
+ Lisp_Object process = XCDR (XCAR (pair));
+ if (EQ (XPROCESS (process)->thread, dying_thread))
+ {
+ struct Lisp_Process *proc = XPROCESS (process);
+
+ pset_thread (proc, Qnil);
+ if (proc->infd >= 0)
+ fd_callback_info[proc->infd].thread = NULL;
+ if (proc->outfd >= 0)
+ fd_callback_info[proc->outfd].thread = NULL;
+ }
+ }
+}
+
#ifdef HAVE_GETADDRINFO_A
static void
free_dns_request (Lisp_Object proc)
@@ -1066,17 +1225,11 @@ static void
set_process_filter_masks (struct Lisp_Process *p)
{
if (EQ (p->filter, Qt) && !EQ (p->status, Qlisten))
- {
- FD_CLR (p->infd, &input_wait_mask);
- FD_CLR (p->infd, &non_keyboard_wait_mask);
- }
+ delete_read_fd (p->infd);
else if (EQ (p->filter, Qt)
/* Network or serial process not stopped: */
&& !EQ (p->command, Qt))
- {
- FD_SET (p->infd, &input_wait_mask);
- FD_SET (p->infd, &non_keyboard_wait_mask);
- }
+ add_process_read_fd (p->infd);
}
DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter,
@@ -1163,6 +1316,44 @@ See `set-process-sentinel' for more info on sentinels.
*/)
return XPROCESS (process)->sentinel;
}
+DEFUN ("set-process-thread", Fset_process_thread, Sset_process_thread,
+ 2, 2, 0,
+ doc: /* Set the locking thread of PROCESS to be THREAD.
+If THREAD is nil, the process is unlocked. */)
+ (Lisp_Object process, Lisp_Object thread)
+{
+ struct Lisp_Process *proc;
+ struct thread_state *tstate;
+
+ CHECK_PROCESS (process);
+ if (NILP (thread))
+ tstate = NULL;
+ else
+ {
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+ }
+
+ proc = XPROCESS (process);
+ pset_thread (proc, thread);
+ if (proc->infd >= 0)
+ fd_callback_info[proc->infd].thread = tstate;
+ if (proc->outfd >= 0)
+ fd_callback_info[proc->outfd].thread = tstate;
+
+ return thread;
+}
+
+DEFUN ("process-thread", Fprocess_thread, Sprocess_thread,
+ 1, 1, 0,
+ doc: /* Ret the locking thread of PROCESS.
+If PROCESS is unlocked, this function returns nil. */)
+ (Lisp_Object process)
+{
+ CHECK_PROCESS (process);
+ return XPROCESS (process)->thread;
+}
+
DEFUN ("set-process-window-size", Fset_process_window_size,
Sset_process_window_size, 3, 3, 0,
doc: /* Tell PROCESS that it has logical window size WIDTH by HEIGHT.
@@ -1840,13 +2031,7 @@ create_process (Lisp_Object process, char **new_argv,
Lisp_Object current_dir)
pset_status (p, Qrun);
if (!EQ (p->command, Qt))
- {
- FD_SET (inchannel, &input_wait_mask);
- FD_SET (inchannel, &non_keyboard_wait_mask);
- }
-
- if (inchannel > max_process_desc)
- max_process_desc = inchannel;
+ add_process_read_fd (inchannel);
/* This may signal an error. */
setup_process_coding_systems (process);
@@ -2079,10 +2264,7 @@ create_pty (Lisp_Object process)
pset_status (p, Qrun);
setup_process_coding_systems (process);
- FD_SET (pty_fd, &input_wait_mask);
- FD_SET (pty_fd, &non_keyboard_wait_mask);
- if (pty_fd > max_process_desc)
- max_process_desc = pty_fd;
+ add_process_read_fd (pty_fd);
pset_tty_name (p, build_string (pty_name));
}
@@ -2166,8 +2348,8 @@ usage: (make-pipe-process &rest ARGS) */)
p->infd = inchannel;
p->outfd = outchannel;
- if (inchannel > max_process_desc)
- max_process_desc = inchannel;
+ if (inchannel > max_desc)
+ max_desc = inchannel;
buffer = Fplist_get (contact, QCbuffer);
if (NILP (buffer))
@@ -2188,10 +2370,7 @@ usage: (make-pipe-process &rest ARGS) */)
eassert (! p->pty_flag);
if (!EQ (p->command, Qt))
- {
- FD_SET (inchannel, &input_wait_mask);
- FD_SET (inchannel, &non_keyboard_wait_mask);
- }
+ add_process_read_fd (inchannel);
p->adaptive_read_buffering
= (NILP (Vprocess_adaptive_read_buffering) ? 0
: EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2);
@@ -2904,8 +3083,8 @@ usage: (make-serial-process &rest ARGS) */)
p->open_fd[SUBPROCESS_STDIN] = fd;
p->infd = fd;
p->outfd = fd;
- if (fd > max_process_desc)
- max_process_desc = fd;
+ if (fd > max_desc)
+ max_desc = fd;
chan_process[fd] = proc;
buffer = Fplist_get (contact, QCbuffer);
@@ -2927,10 +3106,7 @@ usage: (make-serial-process &rest ARGS) */)
eassert (! p->pty_flag);
if (!EQ (p->command, Qt))
- {
- FD_SET (fd, &input_wait_mask);
- FD_SET (fd, &non_keyboard_wait_mask);
- }
+ add_process_read_fd (fd);
if (BUFFERP (buffer))
{
@@ -3102,7 +3278,7 @@ finish_after_tls_connection (Lisp_Object proc)
pset_status (p, Qfailed);
deactivate_process (proc);
}
- else if (! FD_ISSET (p->outfd, &connect_wait_mask))
+ else if ((fd_callback_info[p->outfd].flags & NON_BLOCKING_CONNECT_FD) == 0)
{
/* If we cleared the connection wait mask before we did the TLS
setup, then we have to say that the process is finally "open"
@@ -3412,25 +3588,18 @@ connect_network_socket (Lisp_Object proc, Lisp_Object
addrinfos,
if (! (connecting_status (p->status)
&& EQ (XCDR (p->status), addrinfos)))
pset_status (p, Fcons (Qconnect, addrinfos));
- if (!FD_ISSET (inch, &connect_wait_mask))
- {
- FD_SET (inch, &connect_wait_mask);
- FD_SET (inch, &write_mask);
- num_pending_connects++;
- }
+ if ((fd_callback_info[inch].flags & NON_BLOCKING_CONNECT_FD) == 0)
+ add_non_blocking_write_fd (inch);
}
else
/* A server may have a client filter setting of Qt, but it must
still listen for incoming connects unless it is stopped. */
if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt))
|| (EQ (p->status, Qlisten) && NILP (p->command)))
- {
- FD_SET (inch, &input_wait_mask);
- FD_SET (inch, &non_keyboard_wait_mask);
- }
+ add_process_read_fd (inch);
- if (inch > max_process_desc)
- max_process_desc = inch;
+ if (inch > max_desc)
+ max_desc = inch;
/* Set up the masks based on the process filter. */
set_process_filter_masks (p);
@@ -4361,26 +4530,11 @@ deactivate_process (Lisp_Object proc)
}
#endif
chan_process[inchannel] = Qnil;
- FD_CLR (inchannel, &input_wait_mask);
- FD_CLR (inchannel, &non_keyboard_wait_mask);
- if (FD_ISSET (inchannel, &connect_wait_mask))
- {
- FD_CLR (inchannel, &connect_wait_mask);
- FD_CLR (inchannel, &write_mask);
- if (--num_pending_connects < 0)
- emacs_abort ();
- }
- if (inchannel == max_process_desc)
- {
- /* We just closed the highest-numbered process input descriptor,
- so recompute the highest-numbered one now. */
- int i = inchannel;
- do
- i--;
- while (0 <= i && NILP (chan_process[i]));
-
- max_process_desc = i;
- }
+ delete_read_fd (inchannel);
+ if ((fd_callback_info[inchannel].flags & NON_BLOCKING_CONNECT_FD) != 0)
+ delete_write_fd (inchannel);
+ if (inchannel == max_desc)
+ recompute_max_desc ();
}
}
@@ -4409,7 +4563,18 @@ is nil, from any process) before the timeout expired.
*/)
int nsecs;
if (! NILP (process))
- CHECK_PROCESS (process);
+ {
+ struct Lisp_Process *procp;
+
+ CHECK_PROCESS (process);
+ procp = XPROCESS (process);
+
+ /* Can't wait for a process that is dedicated to a different
+ thread. */
+ if (!EQ (procp->thread, Qnil) && !EQ (procp->thread, Fcurrent_thread ()))
+ error ("Attempt to accept output from process %s locked to thread %s",
+ SDATA (procp->name), SDATA (XTHREAD (procp->thread)->name));
+ }
else
just_this_one = Qnil;
@@ -4627,13 +4792,9 @@ server_accept_connection (Lisp_Object server, int
channel)
/* Client processes for accepted connections are not stopped initially. */
if (!EQ (p->filter, Qt))
- {
- FD_SET (s, &input_wait_mask);
- FD_SET (s, &non_keyboard_wait_mask);
- }
-
- if (s > max_process_desc)
- max_process_desc = s;
+ add_process_read_fd (s);
+ if (s > max_desc)
+ max_desc = s;
/* Setup coding system for new process based on server process.
This seems to be the proper thing to do, as the coding system
@@ -4746,20 +4907,10 @@ wait_for_tls_negotiation (Lisp_Object process)
#endif
}
-/* This variable is different from waiting_for_input in keyboard.c.
- It is used to communicate to a lisp process-filter/sentinel (via the
- function Fwaiting_for_user_input_p below) whether Emacs was waiting
- for user-input when that process-filter was called.
- waiting_for_input cannot be used as that is by definition 0 when
- lisp code is being evalled.
- This is also used in record_asynch_buffer_change.
- For that purpose, this must be 0
- when not inside wait_reading_process_output. */
-static int waiting_for_user_input_p;
-
static void
wait_reading_process_output_unwind (int data)
{
+ clear_waiting_thread_info ();
waiting_for_user_input_p = data;
}
@@ -4832,6 +4983,10 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
/* Close to the current time if known, an invalid timespec otherwise. */
struct timespec now = invalid_timespec ();
+ eassert (wait_proc == NULL
+ || EQ (wait_proc->thread, Qnil)
+ || XTHREAD (wait_proc->thread) == current_thread);
+
FD_ZERO (&Available);
FD_ZERO (&Writeok);
@@ -5004,14 +5159,14 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
if (kbd_on_hold_p ())
FD_ZERO (&Atemp);
else
- Atemp = input_wait_mask;
- Ctemp = write_mask;
+ compute_input_wait_mask (&Atemp);
+ compute_write_mask (&Ctemp);
timeout = make_timespec (0, 0);
- if ((pselect (max (max_process_desc, max_input_desc) + 1,
- &Atemp,
- (num_pending_connects > 0 ? &Ctemp : NULL),
- NULL, &timeout, NULL)
+ if ((thread_select (pselect, max_desc + 1,
+ &Atemp,
+ (num_pending_connects > 0 ? &Ctemp : NULL),
+ NULL, &timeout, NULL)
<= 0))
{
/* It's okay for us to do this and then continue with
@@ -5076,17 +5231,17 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
}
else if (!NILP (wait_for_cell))
{
- Available = non_process_wait_mask;
+ compute_non_process_wait_mask (&Available);
check_delay = 0;
check_write = 0;
}
else
{
if (! read_kbd)
- Available = non_keyboard_wait_mask;
+ compute_non_keyboard_wait_mask (&Available);
else
- Available = input_wait_mask;
- Writeok = write_mask;
+ compute_input_wait_mask (&Available);
+ compute_write_mask (&Writeok);
check_delay = wait_proc ? 0 : process_output_delay_count;
check_write = true;
}
@@ -5128,7 +5283,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
int adaptive_nsecs = timeout.tv_nsec;
if (timeout.tv_sec > 0 || adaptive_nsecs > READ_OUTPUT_DELAY_MAX)
adaptive_nsecs = READ_OUTPUT_DELAY_MAX;
- for (channel = 0; check_delay > 0 && channel <= max_process_desc;
channel++)
+ for (channel = 0; check_delay > 0 && channel <= max_desc;
channel++)
{
proc = chan_process[channel];
if (NILP (proc))
@@ -5187,17 +5342,18 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
}
#endif
+ nfds = thread_select (
#if defined (HAVE_NS)
- nfds = ns_select
+ ns_select
#elif defined (HAVE_GLIB)
- nfds = xg_select
+ xg_select
#else
- nfds = pselect
+ pselect
#endif
- (max (max_process_desc, max_input_desc) + 1,
- &Available,
- (check_write ? &Writeok : 0),
- NULL, &timeout, NULL);
+ , max_desc + 1,
+ &Available,
+ (check_write ? &Writeok : 0),
+ NULL, &timeout, NULL);
#ifdef HAVE_GNUTLS
/* GnuTLS buffers data internally. In lowat mode it leaves
@@ -5381,22 +5537,22 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
if (no_avail || nfds == 0)
continue;
- for (channel = 0; channel <= max_input_desc; ++channel)
+ for (channel = 0; channel <= max_desc; ++channel)
{
struct fd_callback_data *d = &fd_callback_info[channel];
if (d->func
- && ((d->condition & FOR_READ
+ && ((d->flags & FOR_READ
&& FD_ISSET (channel, &Available))
- || (d->condition & FOR_WRITE
- && FD_ISSET (channel, &write_mask))))
+ || ((d->flags & FOR_WRITE)
+ && FD_ISSET (channel, &Writeok))))
d->func (channel, d->data);
}
- for (channel = 0; channel <= max_process_desc; channel++)
+ for (channel = 0; channel <= max_desc; channel++)
{
if (FD_ISSET (channel, &Available)
- && FD_ISSET (channel, &non_keyboard_wait_mask)
- && !FD_ISSET (channel, &non_process_wait_mask))
+ && ((fd_callback_info[channel].flags & (KEYBOARD_FD | PROCESS_FD))
+ == PROCESS_FD))
{
int nread;
@@ -5461,8 +5617,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
/* Clear the descriptor now, so we only raise the
signal once. */
- FD_CLR (channel, &input_wait_mask);
- FD_CLR (channel, &non_keyboard_wait_mask);
+ delete_read_fd (channel);
if (p->pid == -2)
{
@@ -5501,14 +5656,12 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
}
}
if (FD_ISSET (channel, &Writeok)
- && FD_ISSET (channel, &connect_wait_mask))
+ && (fd_callback_info[channel].flags
+ & NON_BLOCKING_CONNECT_FD) != 0)
{
struct Lisp_Process *p;
- FD_CLR (channel, &connect_wait_mask);
- FD_CLR (channel, &write_mask);
- if (--num_pending_connects < 0)
- emacs_abort ();
+ delete_write_fd (channel);
proc = chan_process[channel];
if (NILP (proc))
@@ -5576,10 +5729,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
if (0 <= p->infd && !EQ (p->filter, Qt)
&& !EQ (p->command, Qt))
- {
- FD_SET (p->infd, &input_wait_mask);
- FD_SET (p->infd, &non_keyboard_wait_mask);
- }
+ add_process_read_fd (p->infd);
}
}
} /* End for each file descriptor. */
@@ -6550,10 +6700,7 @@ of incoming traffic. */)
p = XPROCESS (process);
if (NILP (p->command)
&& p->infd >= 0)
- {
- FD_CLR (p->infd, &input_wait_mask);
- FD_CLR (p->infd, &non_keyboard_wait_mask);
- }
+ delete_read_fd (p->infd);
pset_command (p, Qt);
return process;
}
@@ -6582,8 +6729,7 @@ traffic. */)
&& p->infd >= 0
&& (!EQ (p->filter, Qt) || EQ (p->status, Qlisten)))
{
- FD_SET (p->infd, &input_wait_mask);
- FD_SET (p->infd, &non_keyboard_wait_mask);
+ add_process_read_fd (p->infd);
#ifdef WINDOWSNT
if (fd_info[ p->infd ].flags & FILE_SERIAL)
PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR);
@@ -6890,10 +7036,7 @@ handle_child_signal (int sig)
/* clear_desc_flag avoids a compiler bug in Microsoft C. */
if (clear_desc_flag)
- {
- FD_CLR (p->infd, &input_wait_mask);
- FD_CLR (p->infd, &non_keyboard_wait_mask);
- }
+ delete_read_fd (p->infd);
}
}
}
@@ -7253,9 +7396,10 @@ keyboard_bit_set (fd_set *mask)
{
int fd;
- for (fd = 0; fd <= max_input_desc; fd++)
- if (FD_ISSET (fd, mask) && FD_ISSET (fd, &input_wait_mask)
- && !FD_ISSET (fd, &non_keyboard_wait_mask))
+ for (fd = 0; fd <= max_desc; fd++)
+ if (FD_ISSET (fd, mask)
+ && ((fd_callback_info[fd].flags & (FOR_READ | KEYBOARD_FD))
+ == (FOR_READ | KEYBOARD_FD)))
return 1;
return 0;
@@ -7492,14 +7636,8 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
void
add_timer_wait_descriptor (int fd)
{
- FD_SET (fd, &input_wait_mask);
- FD_SET (fd, &non_keyboard_wait_mask);
- FD_SET (fd, &non_process_wait_mask);
- fd_callback_info[fd].func = timerfd_callback;
- fd_callback_info[fd].data = NULL;
- fd_callback_info[fd].condition |= FOR_READ;
- if (fd > max_input_desc)
- max_input_desc = fd;
+ add_read_fd (fd, timerfd_callback, NULL);
+ fd_callback_info[fd].flags &= ~KEYBOARD_FD;
}
#endif /* HAVE_TIMERFD */
@@ -7523,10 +7661,11 @@ void
add_keyboard_wait_descriptor (int desc)
{
#ifdef subprocesses /* Actually means "not MSDOS". */
- FD_SET (desc, &input_wait_mask);
- FD_SET (desc, &non_process_wait_mask);
- if (desc > max_input_desc)
- max_input_desc = desc;
+ eassert (desc >= 0 && desc < FD_SETSIZE);
+ fd_callback_info[desc].flags &= ~PROCESS_FD;
+ fd_callback_info[desc].flags |= (FOR_READ | KEYBOARD_FD);
+ if (desc > max_desc)
+ max_desc = desc;
#endif
}
@@ -7536,9 +7675,12 @@ void
delete_keyboard_wait_descriptor (int desc)
{
#ifdef subprocesses
- FD_CLR (desc, &input_wait_mask);
- FD_CLR (desc, &non_process_wait_mask);
- delete_input_desc (desc);
+ eassert (desc >= 0 && desc < FD_SETSIZE);
+
+ fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD);
+
+ if (desc == max_desc)
+ recompute_max_desc ();
#endif
}
@@ -7819,15 +7961,10 @@ init_process_emacs (int sockfd)
}
#endif
- FD_ZERO (&input_wait_mask);
- FD_ZERO (&non_keyboard_wait_mask);
- FD_ZERO (&non_process_wait_mask);
- FD_ZERO (&write_mask);
- max_process_desc = max_input_desc = -1;
external_sock_fd = sockfd;
+ max_desc = -1;
memset (fd_callback_info, 0, sizeof (fd_callback_info));
- FD_ZERO (&connect_wait_mask);
num_pending_connects = 0;
process_output_delay_count = 0;
@@ -8027,6 +8164,8 @@ The variable takes effect when `start-process' is called.
*/);
defsubr (&Sprocess_filter);
defsubr (&Sset_process_sentinel);
defsubr (&Sprocess_sentinel);
+ defsubr (&Sset_process_thread);
+ defsubr (&Sprocess_thread);
defsubr (&Sset_process_window_size);
defsubr (&Sset_process_inherit_coding_system_flag);
defsubr (&Sset_process_query_on_exit_flag);
diff --git a/src/process.h b/src/process.h
index 24c6282..e497ebc 100644
--- a/src/process.h
+++ b/src/process.h
@@ -115,6 +115,9 @@ struct Lisp_Process
/* Pipe process attached to the standard error of this process. */
Lisp_Object stderrproc;
+ /* The thread a process is linked to, or nil for any thread. */
+ Lisp_Object thread;
+
/* After this point, there are no Lisp_Objects any more. */
/* alloc.c assumes that `pid' is the first such non-Lisp slot. */
@@ -274,6 +277,8 @@ extern Lisp_Object network_interface_info (Lisp_Object);
extern Lisp_Object remove_slash_colon (Lisp_Object);
+extern void update_processes_for_thread_death (Lisp_Object);
+
INLINE_HEADER_END
#endif /* EMACS_PROCESS_H */
diff --git a/src/regex.c b/src/regex.c
index afd0d18..f1686cf 100644
--- a/src/regex.c
+++ b/src/regex.c
@@ -4885,12 +4885,6 @@ re_match (struct re_pattern_buffer *bufp, const char
*string,
WEAK_ALIAS (__re_match, re_match)
#endif /* not emacs */
-#ifdef emacs
-/* In Emacs, this is the string or buffer in which we are matching.
- See the declaration in regex.h for details. */
-Lisp_Object re_match_object;
-#endif
-
/* re_match_2 matches the compiled pattern in BUFP against the
the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1
and SIZE2, respectively). We start matching at POS, and stop
diff --git a/src/regex.h b/src/regex.h
index 4922440..2d720e6 100644
--- a/src/regex.h
+++ b/src/regex.h
@@ -171,7 +171,7 @@ typedef unsigned long reg_syntax_t;
some interfaces). When a regexp is compiled, the syntax used is
stored in the pattern buffer, so changing this does not affect
already-compiled regexps. */
-extern reg_syntax_t re_syntax_options;
+/* extern reg_syntax_t re_syntax_options; */
#ifdef emacs
# include "lisp.h"
@@ -180,8 +180,10 @@ extern reg_syntax_t re_syntax_options;
If the value is a Lisp string object, we are matching text in that
string; if it's nil, we are matching text in the current buffer; if
- it's t, we are matching text in a C string. */
-extern Lisp_Object re_match_object;
+ it's t, we are matching text in a C string.
+
+ This is defined as a macro in thread.h, which see. */
+/* extern Lisp_Object re_match_object; */
#endif
/* Roughly the maximum number of failure points on the stack. */
diff --git a/src/search.c b/src/search.c
index e597c33..9d2c8cb 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/>. */
struct regexp_cache
{
struct regexp_cache *next;
- Lisp_Object regexp, whitespace_regexp;
+ Lisp_Object regexp, f_whitespace_regexp;
/* Syntax table for which the regexp applies. We need this because
of character classes. If this is t, then the compiled pattern is valid
for any syntax-table. */
@@ -75,12 +75,12 @@ static struct regexp_cache *searchbuf_head;
to call re_set_registers after compiling a new pattern or after
setting the match registers, so that the regex functions will be
able to free or re-allocate it properly. */
-static struct re_registers search_regs;
+/* static struct re_registers search_regs; */
/* The buffer in which the last search was performed, or
Qt if the last search was done in a string;
Qnil if no searching has been done yet. */
-static Lisp_Object last_thing_searched;
+/* static Lisp_Object last_thing_searched; */
static void set_search_regs (ptrdiff_t, ptrdiff_t);
static void save_search_regs (void);
@@ -122,9 +122,9 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object
pattern,
cp->buf.multibyte = STRING_MULTIBYTE (pattern);
cp->buf.charset_unibyte = charset_unibyte;
if (STRINGP (Vsearch_spaces_regexp))
- cp->whitespace_regexp = Vsearch_spaces_regexp;
+ cp->f_whitespace_regexp = Vsearch_spaces_regexp;
else
- cp->whitespace_regexp = Qnil;
+ cp->f_whitespace_regexp = Qnil;
/* rms: I think BLOCK_INPUT is not needed here any more,
because regex.c defines malloc to call xmalloc.
@@ -217,7 +217,7 @@ compile_pattern (Lisp_Object pattern, struct re_registers
*regp,
&& cp->posix == posix
&& (EQ (cp->syntax_table, Qt)
|| EQ (cp->syntax_table, BVAR (current_buffer, syntax_table)))
- && !NILP (Fequal (cp->whitespace_regexp, Vsearch_spaces_regexp))
+ && !NILP (Fequal (cp->f_whitespace_regexp, Vsearch_spaces_regexp))
&& cp->buf.charset_unibyte == charset_unibyte)
break;
@@ -3089,9 +3089,9 @@ If optional arg RESEAT is non-nil, make markers on LIST
point nowhere. */)
/* If true the match data have been saved in saved_search_regs
during the execution of a sentinel or filter. */
-static bool search_regs_saved;
-static struct re_registers saved_search_regs;
-static Lisp_Object saved_last_thing_searched;
+/* static bool search_regs_saved; */
+/* static struct re_registers saved_search_regs; */
+/* static Lisp_Object saved_last_thing_searched; */
/* Called from Flooking_at, Fstring_match, search_buffer, Fstore_match_data
if asynchronous code (filter or sentinel) is running. */
@@ -3401,10 +3401,10 @@ syms_of_search (void)
searchbufs[i].buf.buffer = xmalloc (100);
searchbufs[i].buf.fastmap = searchbufs[i].fastmap;
searchbufs[i].regexp = Qnil;
- searchbufs[i].whitespace_regexp = Qnil;
+ searchbufs[i].f_whitespace_regexp = Qnil;
searchbufs[i].syntax_table = Qnil;
staticpro (&searchbufs[i].regexp);
- staticpro (&searchbufs[i].whitespace_regexp);
+ staticpro (&searchbufs[i].f_whitespace_regexp);
staticpro (&searchbufs[i].syntax_table);
searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]);
}
diff --git a/src/sysdep.c b/src/sysdep.c
index 2576342..3d2b9bd 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -51,14 +51,19 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
# include <math.h>
#endif
+#ifdef HAVE_SOCKETS
+#include <sys/socket.h>
+#include <netdb.h>
+#endif /* HAVE_SOCKETS */
+
#ifdef WINDOWSNT
#define read sys_read
#define write sys_write
#ifndef STDERR_FILENO
#define STDERR_FILENO fileno(GetStdHandle(STD_ERROR_HANDLE))
#endif
-#include <windows.h>
-#endif /* not WINDOWSNT */
+#include "w32.h"
+#endif /* WINDOWSNT */
#include <sys/types.h>
#include <sys/stat.h>
diff --git a/src/systhread.c b/src/systhread.c
new file mode 100644
index 0000000..c11e024
--- /dev/null
+++ b/src/systhread.c
@@ -0,0 +1,417 @@
+/* System thread definitions
+ Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <setjmp.h>
+#include "lisp.h"
+
+#ifndef THREADS_ENABLED
+
+void
+sys_mutex_init (sys_mutex_t *m)
+{
+ *m = 0;
+}
+
+void
+sys_mutex_lock (sys_mutex_t *m)
+{
+}
+
+void
+sys_mutex_unlock (sys_mutex_t *m)
+{
+}
+
+void
+sys_mutex_destroy (sys_mutex_t *m)
+{
+}
+
+void
+sys_cond_init (sys_cond_t *c)
+{
+ *c = 0;
+}
+
+void
+sys_cond_wait (sys_cond_t *c, sys_mutex_t *m)
+{
+}
+
+void
+sys_cond_signal (sys_cond_t *c)
+{
+}
+
+void
+sys_cond_broadcast (sys_cond_t *c)
+{
+}
+
+void
+sys_cond_destroy (sys_cond_t *c)
+{
+}
+
+sys_thread_t
+sys_thread_self (void)
+{
+ return 0;
+}
+
+int
+sys_thread_equal (sys_thread_t x, sys_thread_t y)
+{
+ return x == y;
+}
+
+int
+sys_thread_create (sys_thread_t *t, const char *name,
+ thread_creation_function *func, void *datum)
+{
+ return 0;
+}
+
+void
+sys_thread_yield (void)
+{
+}
+
+#elif defined (HAVE_PTHREAD)
+
+#include <sched.h>
+
+#ifdef HAVE_SYS_PRCTL_H
+#include <sys/prctl.h>
+#endif
+
+void
+sys_mutex_init (sys_mutex_t *mutex)
+{
+ pthread_mutex_init (mutex, NULL);
+}
+
+void
+sys_mutex_lock (sys_mutex_t *mutex)
+{
+ pthread_mutex_lock (mutex);
+}
+
+void
+sys_mutex_unlock (sys_mutex_t *mutex)
+{
+ pthread_mutex_unlock (mutex);
+}
+
+void
+sys_mutex_destroy (sys_mutex_t *mutex)
+{
+ pthread_mutex_destroy (mutex);
+}
+
+void
+sys_cond_init (sys_cond_t *cond)
+{
+ pthread_cond_init (cond, NULL);
+}
+
+void
+sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex)
+{
+ pthread_cond_wait (cond, mutex);
+}
+
+void
+sys_cond_signal (sys_cond_t *cond)
+{
+ pthread_cond_signal (cond);
+}
+
+void
+sys_cond_broadcast (sys_cond_t *cond)
+{
+ pthread_cond_broadcast (cond);
+}
+
+void
+sys_cond_destroy (sys_cond_t *cond)
+{
+ pthread_cond_destroy (cond);
+}
+
+sys_thread_t
+sys_thread_self (void)
+{
+ return pthread_self ();
+}
+
+int
+sys_thread_equal (sys_thread_t one, sys_thread_t two)
+{
+ return pthread_equal (one, two);
+}
+
+int
+sys_thread_create (sys_thread_t *thread_ptr, const char *name,
+ thread_creation_function *func, void *arg)
+{
+ pthread_attr_t attr;
+ int result = 0;
+
+ if (pthread_attr_init (&attr))
+ return 0;
+
+ if (!pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED))
+ {
+ result = pthread_create (thread_ptr, &attr, func, arg) == 0;
+#if defined (HAVE_SYS_PRCTL_H) && defined (HAVE_PRCTL) && defined (PR_SET_NAME)
+ if (result && name != NULL)
+ prctl (PR_SET_NAME, name);
+#endif
+ }
+
+ pthread_attr_destroy (&attr);
+
+ return result;
+}
+
+void
+sys_thread_yield (void)
+{
+ sched_yield ();
+}
+
+#elif defined (WINDOWSNT)
+
+#include <windows.h>
+
+/* Cannot include <process.h> because of the local header by the same
+ name, sigh. */
+uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *);
+
+/* Mutexes are implemented as critical sections, because they are
+ faster than Windows mutex objects (implemented in userspace), and
+ satisfy the requirements, since we only need to synchronize within a
+ single process. */
+void
+sys_mutex_init (sys_mutex_t *mutex)
+{
+ InitializeCriticalSection ((LPCRITICAL_SECTION)mutex);
+}
+
+void
+sys_mutex_lock (sys_mutex_t *mutex)
+{
+ /* FIXME: What happens if the owning thread exits without releasing
+ the mutex? Accoding to MSDN, the result is undefined behavior. */
+ EnterCriticalSection ((LPCRITICAL_SECTION)mutex);
+}
+
+void
+sys_mutex_unlock (sys_mutex_t *mutex)
+{
+ LeaveCriticalSection ((LPCRITICAL_SECTION)mutex);
+}
+
+void
+sys_mutex_destroy (sys_mutex_t *mutex)
+{
+ /* FIXME: According to MSDN, deleting a critical session that is
+ owned by a thread leaves the other threads waiting for the
+ critical session in an undefined state. Posix docs seem to say
+ the same about pthread_mutex_destroy. Do we need to protect
+ against such calamities? */
+ DeleteCriticalSection ((LPCRITICAL_SECTION)mutex);
+}
+
+void
+sys_cond_init (sys_cond_t *cond)
+{
+ cond->initialized = false;
+ cond->wait_count = 0;
+ /* Auto-reset event for signal. */
+ cond->events[CONDV_SIGNAL] = CreateEvent (NULL, FALSE, FALSE, NULL);
+ /* Manual-reset event for broadcast. */
+ cond->events[CONDV_BROADCAST] = CreateEvent (NULL, TRUE, FALSE, NULL);
+ if (!cond->events[CONDV_SIGNAL] || !cond->events[CONDV_BROADCAST])
+ return;
+ InitializeCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+ cond->initialized = true;
+}
+
+void
+sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex)
+{
+ DWORD wait_result;
+ bool last_thread_waiting;
+
+ if (!cond->initialized)
+ return;
+
+ /* Increment the wait count avoiding race conditions. */
+ EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+ cond->wait_count++;
+ LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+
+ /* Release the mutex and wait for either the signal or the broadcast
+ event. */
+ LeaveCriticalSection ((LPCRITICAL_SECTION)mutex);
+ wait_result = WaitForMultipleObjects (2, cond->events, FALSE, INFINITE);
+
+ /* Decrement the wait count and see if we are the last thread
+ waiting on the condition variable. */
+ EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+ cond->wait_count--;
+ last_thread_waiting =
+ wait_result == WAIT_OBJECT_0 + CONDV_BROADCAST
+ && cond->wait_count == 0;
+ LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+
+ /* Broadcast uses a manual-reset event, so when the last thread is
+ released, we must manually reset that event. */
+ if (last_thread_waiting)
+ ResetEvent (cond->events[CONDV_BROADCAST]);
+
+ /* Per the API, re-acquire the mutex. */
+ EnterCriticalSection ((LPCRITICAL_SECTION)mutex);
+}
+
+void
+sys_cond_signal (sys_cond_t *cond)
+{
+ bool threads_waiting;
+
+ if (!cond->initialized)
+ return;
+
+ EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+ threads_waiting = cond->wait_count > 0;
+ LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+
+ if (threads_waiting)
+ SetEvent (cond->events[CONDV_SIGNAL]);
+}
+
+void
+sys_cond_broadcast (sys_cond_t *cond)
+{
+ bool threads_waiting;
+
+ if (!cond->initialized)
+ return;
+
+ EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+ threads_waiting = cond->wait_count > 0;
+ LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+
+ if (threads_waiting)
+ SetEvent (cond->events[CONDV_BROADCAST]);
+}
+
+void
+sys_cond_destroy (sys_cond_t *cond)
+{
+ if (cond->events[CONDV_SIGNAL])
+ CloseHandle (cond->events[CONDV_SIGNAL]);
+ if (cond->events[CONDV_BROADCAST])
+ CloseHandle (cond->events[CONDV_BROADCAST]);
+
+ if (!cond->initialized)
+ return;
+
+ /* FIXME: What if wait_count is non-zero, i.e. there are still
+ threads waiting on this condition variable? */
+ DeleteCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+}
+
+sys_thread_t
+sys_thread_self (void)
+{
+ return (sys_thread_t) GetCurrentThreadId ();
+}
+
+int
+sys_thread_equal (sys_thread_t one, sys_thread_t two)
+{
+ return one == two;
+}
+
+static thread_creation_function *thread_start_address;
+
+/* _beginthread wants a void function, while we are passed a function
+ that returns a pointer. So we use a wrapper. */
+static void
+w32_beginthread_wrapper (void *arg)
+{
+ (void)thread_start_address (arg);
+}
+
+int
+sys_thread_create (sys_thread_t *thread_ptr, const char *name,
+ thread_creation_function *func, void *arg)
+{
+ /* FIXME: Do threads that run Lisp require some minimum amount of
+ stack? Zero here means each thread will get the same amount as
+ the main program. On GNU/Linux, it seems like the stack is 2MB
+ by default, overridden by RLIMIT_STACK at program start time.
+ Not sure what to do with this. See also the comment in
+ w32proc.c:new_child. */
+ const unsigned stack_size = 0;
+ uintptr_t thandle;
+
+ thread_start_address = func;
+
+ /* We use _beginthread rather than CreateThread because the former
+ arranges for the thread handle to be automatically closed when
+ the thread exits, thus preventing handle leaks and/or the need to
+ track all the threads and close their handles when they exit.
+ Also, MSDN seems to imply that code which uses CRT _must_ call
+ _beginthread, although if that is true, we already violate that
+ rule in many places... */
+ thandle = _beginthread (w32_beginthread_wrapper, stack_size, arg);
+ if (thandle == (uintptr_t)-1L)
+ return 0;
+
+ /* Kludge alert! We use the Windows thread ID, an unsigned 32-bit
+ number, as the sys_thread_t type, because that ID is the only
+ unique identifier of a thread on Windows. But _beginthread
+ returns a handle of the thread, and there's no easy way of
+ getting the thread ID given a handle (GetThreadId is available
+ only since Vista, so we cannot use it portably). Fortunately,
+ the value returned by sys_thread_create is not used by its
+ callers; instead, run_thread, which runs in the context of the
+ new thread, calls sys_thread_self and uses its return value;
+ sys_thread_self in this implementation calls GetCurrentThreadId.
+ Therefore, we return some more or less arbitrary value of the
+ thread ID from this function. */
+ *thread_ptr = thandle & 0xFFFFFFFF;
+ return 1;
+}
+
+void
+sys_thread_yield (void)
+{
+ Sleep (0);
+}
+
+#else
+
+#error port me
+
+#endif
diff --git a/src/systhread.h b/src/systhread.h
new file mode 100644
index 0000000..b38fd8f
--- /dev/null
+++ b/src/systhread.h
@@ -0,0 +1,112 @@
+/* System thread definitions
+ Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef SYSTHREAD_H
+#define SYSTHREAD_H
+
+#ifdef THREADS_ENABLED
+
+#ifdef HAVE_PTHREAD
+
+#include <pthread.h>
+
+/* A system mutex is just a pthread mutex. This is only used for the
+ GIL. */
+typedef pthread_mutex_t sys_mutex_t;
+
+typedef pthread_cond_t sys_cond_t;
+
+/* A system thread. */
+typedef pthread_t sys_thread_t;
+
+#else /* HAVE_PTHREAD */
+
+#ifdef WINDOWSNT
+
+/* This header is indirectly included in every source file. We don't
+ want to include windows.h in every source file, so we repeat
+ declarations of the few necessary data types here (under different
+ names, to avoid conflicts with files that do include
+ windows.h). */
+
+typedef struct {
+ struct _CRITICAL_SECTION_DEBUG *DebugInfo;
+ long LockCount;
+ long RecursionCount;
+ void *OwningThread;
+ void *LockSemaphore;
+ unsigned long SpinCount;
+} w32thread_critsect;
+
+enum { CONDV_SIGNAL = 0, CONDV_BROADCAST = 1, CONDV_MAX = 2 };
+
+typedef struct {
+ /* Count of threads that are waiting for this condition variable. */
+ unsigned wait_count;
+ /* Critical section to protect changes to the count above. */
+ w32thread_critsect wait_count_lock;
+ /* Handles of events used for signal and broadcast. */
+ void *events[CONDV_MAX];
+ bool initialized;
+} w32thread_cond_t;
+
+typedef w32thread_critsect sys_mutex_t;
+
+typedef w32thread_cond_t sys_cond_t;
+
+typedef unsigned long sys_thread_t;
+
+#else /* !WINDOWSNT */
+
+#error port me
+
+#endif /* WINDOWSNT */
+#endif /* HAVE_PTHREAD */
+
+#else /* THREADS_ENABLED */
+
+/* For the no-threads case we can simply use dummy definitions. */
+typedef int sys_mutex_t;
+typedef int sys_cond_t;
+typedef int sys_thread_t;
+
+#endif /* THREADS_ENABLED */
+
+typedef void *(thread_creation_function) (void *);
+
+extern void sys_mutex_init (sys_mutex_t *);
+extern void sys_mutex_lock (sys_mutex_t *);
+extern void sys_mutex_unlock (sys_mutex_t *);
+extern void sys_mutex_destroy (sys_mutex_t *);
+
+extern void sys_cond_init (sys_cond_t *);
+extern void sys_cond_wait (sys_cond_t *, sys_mutex_t *);
+extern void sys_cond_signal (sys_cond_t *);
+extern void sys_cond_broadcast (sys_cond_t *);
+extern void sys_cond_destroy (sys_cond_t *);
+
+extern sys_thread_t sys_thread_self (void);
+extern int sys_thread_equal (sys_thread_t, sys_thread_t);
+
+extern int sys_thread_create (sys_thread_t *, const char *,
+ thread_creation_function *,
+ void *);
+
+extern void sys_thread_yield (void);
+
+#endif /* SYSTHREAD_H */
diff --git a/src/thread.c b/src/thread.c
new file mode 100644
index 0000000..ae2ce3d
--- /dev/null
+++ b/src/thread.c
@@ -0,0 +1,970 @@
+/* Threading code.
+ Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+
+#include <config.h>
+#include <setjmp.h>
+#include "lisp.h"
+#include "character.h"
+#include "buffer.h"
+#include "process.h"
+#include "coding.h"
+
+static struct thread_state primary_thread;
+
+struct thread_state *current_thread = &primary_thread;
+
+static struct thread_state *all_threads = &primary_thread;
+
+static sys_mutex_t global_lock;
+
+extern int poll_suppress_count;
+extern volatile int interrupt_input_blocked;
+
+
+
+/* m_specpdl is set when the thread is created and cleared when the
+ thread dies. */
+#define thread_alive_p(STATE) ((STATE)->m_specpdl != NULL)
+
+
+
+static void
+release_global_lock (void)
+{
+ sys_mutex_unlock (&global_lock);
+}
+
+/* You must call this after acquiring the global lock.
+ acquire_global_lock does it for you. */
+static void
+post_acquire_global_lock (struct thread_state *self)
+{
+ Lisp_Object buffer;
+ struct thread_state *prev_thread = current_thread;
+
+ /* Do this early on, so that code below could signal errors (e.g.,
+ unbind_for_thread_switch might) correctly, because we are already
+ running in the context of the thread pointed by SELF. */
+ current_thread = self;
+
+ if (prev_thread != current_thread)
+ {
+ /* PREV_THREAD is NULL if the previously current thread
+ exited. In this case, there is no reason to unbind, and
+ trying will crash. */
+ if (prev_thread != NULL)
+ unbind_for_thread_switch (prev_thread);
+ rebind_for_thread_switch ();
+ }
+
+ /* We need special handling to re-set the buffer. */
+ XSETBUFFER (buffer, self->m_current_buffer);
+ self->m_current_buffer = 0;
+ set_buffer_internal (XBUFFER (buffer));
+
+ if (!NILP (current_thread->error_symbol))
+ {
+ Lisp_Object sym = current_thread->error_symbol;
+ Lisp_Object data = current_thread->error_data;
+
+ current_thread->error_symbol = Qnil;
+ current_thread->error_data = Qnil;
+ Fsignal (sym, data);
+ }
+}
+
+static void
+acquire_global_lock (struct thread_state *self)
+{
+ sys_mutex_lock (&global_lock);
+ post_acquire_global_lock (self);
+}
+
+
+
+static void
+lisp_mutex_init (lisp_mutex_t *mutex)
+{
+ mutex->owner = NULL;
+ mutex->count = 0;
+ sys_cond_init (&mutex->condition);
+}
+
+static int
+lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
+{
+ struct thread_state *self;
+
+ if (mutex->owner == NULL)
+ {
+ mutex->owner = current_thread;
+ mutex->count = new_count == 0 ? 1 : new_count;
+ return 0;
+ }
+ if (mutex->owner == current_thread)
+ {
+ eassert (new_count == 0);
+ ++mutex->count;
+ return 0;
+ }
+
+ self = current_thread;
+ self->wait_condvar = &mutex->condition;
+ while (mutex->owner != NULL && (new_count != 0
+ || NILP (self->error_symbol)))
+ sys_cond_wait (&mutex->condition, &global_lock);
+ self->wait_condvar = NULL;
+
+ if (new_count == 0 && !NILP (self->error_symbol))
+ return 1;
+
+ mutex->owner = self;
+ mutex->count = new_count == 0 ? 1 : new_count;
+
+ return 1;
+}
+
+static int
+lisp_mutex_unlock (lisp_mutex_t *mutex)
+{
+ if (mutex->owner != current_thread)
+ error ("Cannot unlock mutex owned by another thread");
+
+ if (--mutex->count > 0)
+ return 0;
+
+ mutex->owner = NULL;
+ sys_cond_broadcast (&mutex->condition);
+
+ return 1;
+}
+
+static unsigned int
+lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex)
+{
+ unsigned int result = mutex->count;
+
+ /* Ensured by condvar code. */
+ eassert (mutex->owner == current_thread);
+
+ mutex->count = 0;
+ mutex->owner = NULL;
+ sys_cond_broadcast (&mutex->condition);
+
+ return result;
+}
+
+static void
+lisp_mutex_destroy (lisp_mutex_t *mutex)
+{
+ sys_cond_destroy (&mutex->condition);
+}
+
+static int
+lisp_mutex_owned_p (lisp_mutex_t *mutex)
+{
+ return mutex->owner == current_thread;
+}
+
+
+
+DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
+ doc: /* Create a mutex.
+A mutex provides a synchronization point for threads.
+Only one thread at a time can hold a mutex. Other threads attempting
+to acquire it will block until the mutex is available.
+
+A thread can acquire a mutex any number of times.
+
+NAME, if given, is used as the name of the mutex. The name is
+informational only. */)
+ (Lisp_Object name)
+{
+ struct Lisp_Mutex *mutex;
+ Lisp_Object result;
+
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
+ memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
+ 0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
+ mutex));
+ mutex->name = name;
+ lisp_mutex_init (&mutex->mutex);
+
+ XSETMUTEX (result, mutex);
+ return result;
+}
+
+static void
+mutex_lock_callback (void *arg)
+{
+ struct Lisp_Mutex *mutex = arg;
+ struct thread_state *self = current_thread;
+
+ if (lisp_mutex_lock (&mutex->mutex, 0))
+ post_acquire_global_lock (self);
+}
+
+static void
+do_unwind_mutex_lock (void)
+{
+ current_thread->event_object = Qnil;
+}
+
+DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
+ doc: /* Acquire a mutex.
+If the current thread already owns MUTEX, increment the count and
+return.
+Otherwise, if no thread owns MUTEX, make the current thread own it.
+Otherwise, block until MUTEX is available, or until the current thread
+is signalled using `thread-signal'.
+Note that calls to `mutex-lock' and `mutex-unlock' must be paired. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ current_thread->event_object = mutex;
+ record_unwind_protect_void (do_unwind_mutex_lock);
+ flush_stack_call_func (mutex_lock_callback, lmutex);
+ return unbind_to (count, Qnil);
+}
+
+static void
+mutex_unlock_callback (void *arg)
+{
+ struct Lisp_Mutex *mutex = arg;
+ struct thread_state *self = current_thread;
+
+ if (lisp_mutex_unlock (&mutex->mutex))
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
+ doc: /* Release the mutex.
+If this thread does not own MUTEX, signal an error.
+Otherwise, decrement the mutex's count. If the count is zero,
+release MUTEX. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ flush_stack_call_func (mutex_unlock_callback, lmutex);
+ return Qnil;
+}
+
+DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0,
+ doc: /* Return the name of MUTEX.
+If no name was given when MUTEX was created, return nil. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ return lmutex->name;
+}
+
+void
+finalize_one_mutex (struct Lisp_Mutex *mutex)
+{
+ lisp_mutex_destroy (&mutex->mutex);
+}
+
+
+
+DEFUN ("make-condition-variable",
+ Fmake_condition_variable, Smake_condition_variable,
+ 1, 2, 0,
+ doc: /* Make a condition variable associated with MUTEX.
+A condition variable provides a way for a thread to sleep while
+waiting for a state change.
+
+MUTEX is the mutex associated with this condition variable.
+NAME, if given, is the name of this condition variable. The name is
+informational only. */)
+ (Lisp_Object mutex, Lisp_Object name)
+{
+ struct Lisp_CondVar *condvar;
+ Lisp_Object result;
+
+ CHECK_MUTEX (mutex);
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
+ memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
+ 0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
+ cond));
+ condvar->mutex = mutex;
+ condvar->name = name;
+ sys_cond_init (&condvar->cond);
+
+ XSETCONDVAR (result, condvar);
+ return result;
+}
+
+static void
+condition_wait_callback (void *arg)
+{
+ struct Lisp_CondVar *cvar = arg;
+ struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex);
+ struct thread_state *self = current_thread;
+ unsigned int saved_count;
+ Lisp_Object cond;
+
+ XSETCONDVAR (cond, cvar);
+ self->event_object = cond;
+ saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+ /* If we were signalled while unlocking, we skip the wait, but we
+ still must reacquire our lock. */
+ if (NILP (self->error_symbol))
+ {
+ self->wait_condvar = &cvar->cond;
+ sys_cond_wait (&cvar->cond, &global_lock);
+ self->wait_condvar = NULL;
+ }
+ lisp_mutex_lock (&mutex->mutex, saved_count);
+ self->event_object = Qnil;
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
+ doc: /* Wait for the condition variable COND to be notified.
+COND is the condition variable to wait on.
+
+The mutex associated with COND must be held when this is called.
+It is an error if it is not held.
+
+This releases the mutex and waits for COND to be notified or for
+this thread to be signalled with `thread-signal'. When
+`condition-wait' returns, COND's mutex will again be locked by
+this thread. */)
+ (Lisp_Object cond)
+{
+ struct Lisp_CondVar *cvar;
+ struct Lisp_Mutex *mutex;
+
+ CHECK_CONDVAR (cond);
+ cvar = XCONDVAR (cond);
+
+ mutex = XMUTEX (cvar->mutex);
+ if (!lisp_mutex_owned_p (&mutex->mutex))
+ error ("Condition variable's mutex is not held by current thread");
+
+ flush_stack_call_func (condition_wait_callback, cvar);
+
+ return Qnil;
+}
+
+/* Used to communicate argumnets to condition_notify_callback. */
+struct notify_args
+{
+ struct Lisp_CondVar *cvar;
+ int all;
+};
+
+static void
+condition_notify_callback (void *arg)
+{
+ struct notify_args *na = arg;
+ struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex);
+ struct thread_state *self = current_thread;
+ unsigned int saved_count;
+ Lisp_Object cond;
+
+ XSETCONDVAR (cond, na->cvar);
+ saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+ if (na->all)
+ sys_cond_broadcast (&na->cvar->cond);
+ else
+ sys_cond_signal (&na->cvar->cond);
+ lisp_mutex_lock (&mutex->mutex, saved_count);
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0,
+ doc: /* Notify COND, a condition variable.
+This wakes a thread waiting on COND.
+If ALL is non-nil, all waiting threads are awoken.
+
+The mutex associated with COND must be held when this is called.
+It is an error if it is not held.
+
+This releases COND's mutex when notifying COND. When
+`condition-notify' returns, the mutex will again be locked by this
+thread. */)
+ (Lisp_Object cond, Lisp_Object all)
+{
+ struct Lisp_CondVar *cvar;
+ struct Lisp_Mutex *mutex;
+ struct notify_args args;
+
+ CHECK_CONDVAR (cond);
+ cvar = XCONDVAR (cond);
+
+ mutex = XMUTEX (cvar->mutex);
+ if (!lisp_mutex_owned_p (&mutex->mutex))
+ error ("Condition variable's mutex is not held by current thread");
+
+ args.cvar = cvar;
+ args.all = !NILP (all);
+ flush_stack_call_func (condition_notify_callback, &args);
+
+ return Qnil;
+}
+
+DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0,
+ doc: /* Return the mutex associated with condition variable COND. */)
+ (Lisp_Object cond)
+{
+ struct Lisp_CondVar *cvar;
+
+ CHECK_CONDVAR (cond);
+ cvar = XCONDVAR (cond);
+
+ return cvar->mutex;
+}
+
+DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0,
+ doc: /* Return the name of condition variable COND.
+If no name was given when COND was created, return nil. */)
+ (Lisp_Object cond)
+{
+ struct Lisp_CondVar *cvar;
+
+ CHECK_CONDVAR (cond);
+ cvar = XCONDVAR (cond);
+
+ return cvar->name;
+}
+
+void
+finalize_one_condvar (struct Lisp_CondVar *condvar)
+{
+ sys_cond_destroy (&condvar->cond);
+}
+
+
+
+struct select_args
+{
+ select_func *func;
+ int max_fds;
+ fd_set *rfds;
+ fd_set *wfds;
+ fd_set *efds;
+ struct timespec *timeout;
+ sigset_t *sigmask;
+ int result;
+};
+
+static void
+really_call_select (void *arg)
+{
+ struct select_args *sa = arg;
+ struct thread_state *self = current_thread;
+
+ release_global_lock ();
+ sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
+ sa->timeout, sa->sigmask);
+ acquire_global_lock (self);
+}
+
+int
+thread_select (select_func *func, int max_fds, fd_set *rfds,
+ fd_set *wfds, fd_set *efds, struct timespec *timeout,
+ sigset_t *sigmask)
+{
+ struct select_args sa;
+
+ sa.func = func;
+ sa.max_fds = max_fds;
+ sa.rfds = rfds;
+ sa.wfds = wfds;
+ sa.efds = efds;
+ sa.timeout = timeout;
+ sa.sigmask = sigmask;
+ flush_stack_call_func (really_call_select, &sa);
+ return sa.result;
+}
+
+
+
+static void
+mark_one_thread (struct thread_state *thread)
+{
+ struct handler *handler;
+ Lisp_Object tem;
+
+ mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
+
+ mark_stack (thread->m_stack_bottom, thread->stack_top);
+
+ for (handler = thread->m_handlerlist; handler; handler = handler->next)
+ {
+ mark_object (handler->tag_or_ch);
+ mark_object (handler->val);
+ }
+
+ if (thread->m_current_buffer)
+ {
+ XSETBUFFER (tem, thread->m_current_buffer);
+ mark_object (tem);
+ }
+
+ mark_object (thread->m_last_thing_searched);
+
+ if (!NILP (thread->m_saved_last_thing_searched))
+ mark_object (thread->m_saved_last_thing_searched);
+}
+
+static void
+mark_threads_callback (void *ignore)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ Lisp_Object thread_obj;
+
+ XSETTHREAD (thread_obj, iter);
+ mark_object (thread_obj);
+ mark_one_thread (iter);
+ }
+}
+
+void
+mark_threads (void)
+{
+ flush_stack_call_func (mark_threads_callback, NULL);
+}
+
+void
+unmark_threads (void)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ if (iter->m_byte_stack_list)
+ relocate_byte_stack (iter->m_byte_stack_list);
+}
+
+
+
+static void
+yield_callback (void *ignore)
+{
+ struct thread_state *self = current_thread;
+
+ release_global_lock ();
+ sys_thread_yield ();
+ acquire_global_lock (self);
+}
+
+DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
+ doc: /* Yield the CPU to another thread. */)
+ (void)
+{
+ flush_stack_call_func (yield_callback, NULL);
+ return Qnil;
+}
+
+static Lisp_Object
+invoke_thread_function (void)
+{
+ int count = SPECPDL_INDEX ();
+
+ Ffuncall (1, ¤t_thread->function);
+ return unbind_to (count, Qnil);
+}
+
+static Lisp_Object
+do_nothing (Lisp_Object whatever)
+{
+ return whatever;
+}
+
+static void *
+run_thread (void *state)
+{
+ char stack_pos;
+ struct thread_state *self = state;
+ struct thread_state **iter;
+
+ self->m_stack_bottom = &stack_pos;
+ self->stack_top = &stack_pos;
+ self->thread_id = sys_thread_self ();
+
+ acquire_global_lock (self);
+
+ { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
+ This is important since handlerlist->nextfree holds the freelist
+ which would otherwise leak every time we unwind back to top-level. */
+ handlerlist_sentinel = xzalloc (sizeof (struct handler));
+ handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
+ struct handler *c = push_handler (Qunbound, CATCHER);
+ eassert (c == handlerlist_sentinel);
+ handlerlist_sentinel->nextfree = NULL;
+ handlerlist_sentinel->next = NULL;
+ }
+
+ /* It might be nice to do something with errors here. */
+ internal_condition_case (invoke_thread_function, Qt, do_nothing);
+
+ update_processes_for_thread_death (Fcurrent_thread ());
+
+ xfree (self->m_specpdl - 1);
+ self->m_specpdl = NULL;
+ self->m_specpdl_ptr = NULL;
+ self->m_specpdl_size = 0;
+
+ {
+ struct handler *c, *c_next;
+ for (c = handlerlist_sentinel; c; c = c_next)
+ {
+ c_next = c->nextfree;
+ xfree (c);
+ }
+ }
+
+ current_thread = NULL;
+ sys_cond_broadcast (&self->thread_condvar);
+
+ /* Unlink this thread from the list of all threads. Note that we
+ have to do this very late, after broadcasting our death.
+ Otherwise the GC may decide to reap the thread_state object,
+ leading to crashes. */
+ for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
+ ;
+ *iter = (*iter)->next_thread;
+
+ release_global_lock ();
+
+ return NULL;
+}
+
+void
+finalize_one_thread (struct thread_state *state)
+{
+ sys_cond_destroy (&state->thread_condvar);
+}
+
+DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
+ doc: /* Start a new thread and run FUNCTION in it.
+When the function exits, the thread dies.
+If NAME is given, it must be a string; it names the new thread. */)
+ (Lisp_Object function, Lisp_Object name)
+{
+ sys_thread_t thr;
+ struct thread_state *new_thread;
+ Lisp_Object result;
+ const char *c_name = NULL;
+ size_t offset = offsetof (struct thread_state, m_byte_stack_list);
+
+ /* Can't start a thread in temacs. */
+ if (!initialized)
+ emacs_abort ();
+
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_byte_stack_list,
+ PVEC_THREAD);
+ memset ((char *) new_thread + offset, 0,
+ sizeof (struct thread_state) - offset);
+
+ new_thread->function = function;
+ new_thread->name = name;
+ new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
+ new_thread->m_saved_last_thing_searched = Qnil;
+ new_thread->m_current_buffer = current_thread->m_current_buffer;
+ new_thread->error_symbol = Qnil;
+ new_thread->error_data = Qnil;
+ new_thread->event_object = Qnil;
+
+ new_thread->m_specpdl_size = 50;
+ new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
+ * sizeof (union specbinding));
+ /* Skip the dummy entry. */
+ ++new_thread->m_specpdl;
+ new_thread->m_specpdl_ptr = new_thread->m_specpdl;
+
+ sys_cond_init (&new_thread->thread_condvar);
+
+ /* We'll need locking here eventually. */
+ new_thread->next_thread = all_threads;
+ all_threads = new_thread;
+
+ if (!NILP (name))
+ c_name = SSDATA (ENCODE_UTF_8 (name));
+
+ if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
+ {
+ /* Restore the previous situation. */
+ all_threads = all_threads->next_thread;
+ error ("Could not start a new thread");
+ }
+
+ /* FIXME: race here where new thread might not be filled in? */
+ XSETTHREAD (result, new_thread);
+ return result;
+}
+
+DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
+ doc: /* Return the current thread. */)
+ (void)
+{
+ Lisp_Object result;
+ XSETTHREAD (result, current_thread);
+ return result;
+}
+
+DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
+ doc: /* Return the name of the THREAD.
+The name is the same object that was passed to `make-thread'. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return tstate->name;
+}
+
+static void
+thread_signal_callback (void *arg)
+{
+ struct thread_state *tstate = arg;
+ struct thread_state *self = current_thread;
+
+ sys_cond_broadcast (tstate->wait_condvar);
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
+ doc: /* Signal an error in a thread.
+This acts like `signal', but arranges for the signal to be raised
+in THREAD. If THREAD is the current thread, acts just like `signal'.
+This will interrupt a blocked call to `mutex-lock', `condition-wait',
+or `thread-join' in the target thread. */)
+ (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ if (tstate == current_thread)
+ Fsignal (error_symbol, data);
+
+ /* What to do if thread is already signalled? */
+ /* What if error_symbol is Qnil? */
+ tstate->error_symbol = error_symbol;
+ tstate->error_data = data;
+
+ if (tstate->wait_condvar)
+ flush_stack_call_func (thread_signal_callback, tstate);
+
+ return Qnil;
+}
+
+DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
+ doc: /* Return t if THREAD is alive, or nil if it has exited. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return thread_alive_p (tstate) ? Qt : Qnil;
+}
+
+DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
+ doc: /* Return the object that THREAD is blocking on.
+If THREAD is blocked in `thread-join' on a second thread, return that
+thread.
+If THREAD is blocked in `mutex-lock', return the mutex.
+If THREAD is blocked in `condition-wait', return the condition variable.
+Otherwise, if THREAD is not blocked, return nil. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return tstate->event_object;
+}
+
+static void
+thread_join_callback (void *arg)
+{
+ struct thread_state *tstate = arg;
+ struct thread_state *self = current_thread;
+ Lisp_Object thread;
+
+ XSETTHREAD (thread, tstate);
+ self->event_object = thread;
+ self->wait_condvar = &tstate->thread_condvar;
+ while (thread_alive_p (tstate) && NILP (self->error_symbol))
+ sys_cond_wait (self->wait_condvar, &global_lock);
+
+ self->wait_condvar = NULL;
+ self->event_object = Qnil;
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
+ doc: /* Wait for THREAD to exit.
+This blocks the current thread until THREAD exits or until
+the current thread is signaled.
+It is an error for a thread to try to join itself. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ if (tstate == current_thread)
+ error ("Cannot join current thread");
+
+ if (thread_alive_p (tstate))
+ flush_stack_call_func (thread_join_callback, tstate);
+
+ return Qnil;
+}
+
+DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
+ doc: /* Return a list of all the live threads. */)
+ (void)
+{
+ Lisp_Object result = Qnil;
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ if (thread_alive_p (iter))
+ {
+ Lisp_Object thread;
+
+ XSETTHREAD (thread, iter);
+ result = Fcons (thread, result);
+ }
+ }
+
+ return result;
+}
+
+
+
+bool
+thread_check_current_buffer (struct buffer *buffer)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ if (iter == current_thread)
+ continue;
+
+ if (iter->m_current_buffer == buffer)
+ return true;
+ }
+
+ return false;
+}
+
+
+
+static void
+init_primary_thread (void)
+{
+ primary_thread.header.size
+ = PSEUDOVECSIZE (struct thread_state, m_byte_stack_list);
+ XSETPVECTYPE (&primary_thread, PVEC_THREAD);
+ primary_thread.m_last_thing_searched = Qnil;
+ primary_thread.m_saved_last_thing_searched = Qnil;
+ primary_thread.name = Qnil;
+ primary_thread.function = Qnil;
+ primary_thread.error_symbol = Qnil;
+ primary_thread.error_data = Qnil;
+ primary_thread.event_object = Qnil;
+}
+
+void
+init_threads_once (void)
+{
+ init_primary_thread ();
+}
+
+void
+init_threads (void)
+{
+ init_primary_thread ();
+ sys_cond_init (&primary_thread.thread_condvar);
+ sys_mutex_init (&global_lock);
+ sys_mutex_lock (&global_lock);
+ current_thread = &primary_thread;
+ primary_thread.thread_id = sys_thread_self ();
+}
+
+void
+syms_of_threads (void)
+{
+#ifndef THREADS_ENABLED
+ if (0)
+#endif
+ {
+ defsubr (&Sthread_yield);
+ defsubr (&Smake_thread);
+ defsubr (&Scurrent_thread);
+ defsubr (&Sthread_name);
+ defsubr (&Sthread_signal);
+ defsubr (&Sthread_alive_p);
+ defsubr (&Sthread_join);
+ defsubr (&Sthread_blocker);
+ defsubr (&Sall_threads);
+ defsubr (&Smake_mutex);
+ defsubr (&Smutex_lock);
+ defsubr (&Smutex_unlock);
+ defsubr (&Smutex_name);
+ defsubr (&Smake_condition_variable);
+ defsubr (&Scondition_wait);
+ defsubr (&Scondition_notify);
+ defsubr (&Scondition_mutex);
+ defsubr (&Scondition_name);
+ }
+
+ DEFSYM (Qthreadp, "threadp");
+ DEFSYM (Qmutexp, "mutexp");
+ DEFSYM (Qcondition_variable_p, "condition-variable-p");
+}
diff --git a/src/thread.h b/src/thread.h
new file mode 100644
index 0000000..a9de754
--- /dev/null
+++ b/src/thread.h
@@ -0,0 +1,237 @@
+/* Thread definitions
+ Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef THREAD_H
+#define THREAD_H
+
+#include <sys/types.h> /* for ssize_t used by regex.h */
+#include "regex.h"
+
+#ifdef WINDOWSNT
+#include <sys/socket.h>
+#endif
+
+#include "sysselect.h" /* FIXME */
+#include "systime.h" /* FIXME */
+
+struct thread_state
+{
+ struct vectorlike_header header;
+
+ /* The buffer in which the last search was performed, or
+ Qt if the last search was done in a string;
+ Qnil if no searching has been done yet. */
+ Lisp_Object m_last_thing_searched;
+#define last_thing_searched (current_thread->m_last_thing_searched)
+
+ Lisp_Object m_saved_last_thing_searched;
+#define saved_last_thing_searched (current_thread->m_saved_last_thing_searched)
+
+ /* The thread's name. */
+ Lisp_Object name;
+
+ /* The thread's function. */
+ Lisp_Object function;
+
+ /* If non-nil, this thread has been signalled. */
+ Lisp_Object error_symbol;
+ Lisp_Object error_data;
+
+ /* If we are waiting for some event, this holds the object we are
+ waiting on. */
+ Lisp_Object event_object;
+
+ /* m_byte_stack_list must be the first non-lisp field. */
+ /* A list of currently active byte-code execution value stacks.
+ Fbyte_code adds an entry to the head of this list before it starts
+ processing byte-code, and it removed the entry again when it is
+ done. Signalling an error truncates the list. */
+ struct byte_stack *m_byte_stack_list;
+#define byte_stack_list (current_thread->m_byte_stack_list)
+
+ /* An address near the bottom of the stack.
+ Tells GC how to save a copy of the stack. */
+ char *m_stack_bottom;
+#define stack_bottom (current_thread->m_stack_bottom)
+
+ /* An address near the top of the stack. */
+ char *stack_top;
+
+ struct catchtag *m_catchlist;
+#define catchlist (current_thread->m_catchlist)
+
+ /* Chain of condition handlers currently in effect.
+ The elements of this chain are contained in the stack frames
+ of Fcondition_case and internal_condition_case.
+ When an error is signaled (by calling Fsignal, below),
+ this chain is searched for an element that applies. */
+ struct handler *m_handlerlist;
+#define handlerlist (current_thread->m_handlerlist)
+
+ struct handler *m_handlerlist_sentinel;
+#define handlerlist_sentinel (current_thread->m_handlerlist_sentinel)
+
+ /* Current number of specbindings allocated in specpdl. */
+ ptrdiff_t m_specpdl_size;
+#define specpdl_size (current_thread->m_specpdl_size)
+
+ /* Pointer to beginning of specpdl. */
+ union specbinding *m_specpdl;
+#define specpdl (current_thread->m_specpdl)
+
+ /* Pointer to first unused element in specpdl. */
+ union specbinding *m_specpdl_ptr;
+#define specpdl_ptr (current_thread->m_specpdl_ptr)
+
+ /* Depth in Lisp evaluations and function calls. */
+ EMACS_INT m_lisp_eval_depth;
+#define lisp_eval_depth (current_thread->m_lisp_eval_depth)
+
+ /* This points to the current buffer. */
+ struct buffer *m_current_buffer;
+#define current_buffer (current_thread->m_current_buffer)
+
+ /* Every call to re_match, etc., must pass &search_regs as the regs
+ argument unless you can show it is unnecessary (i.e., if re_match
+ is certainly going to be called again before region-around-match
+ can be called).
+
+ Since the registers are now dynamically allocated, we need to make
+ sure not to refer to the Nth register before checking that it has
+ been allocated by checking search_regs.num_regs.
+
+ The regex code keeps track of whether it has allocated the search
+ buffer using bits in the re_pattern_buffer. This means that whenever
+ you compile a new pattern, it completely forgets whether it has
+ allocated any registers, and will allocate new registers the next
+ time you call a searching or matching function. Therefore, we need
+ to call re_set_registers after compiling a new pattern or after
+ setting the match registers, so that the regex functions will be
+ able to free or re-allocate it properly. */
+ struct re_registers m_search_regs;
+#define search_regs (current_thread->m_search_regs)
+
+ /* If non-zero the match data have been saved in saved_search_regs
+ during the execution of a sentinel or filter. */
+ bool m_search_regs_saved;
+#define search_regs_saved (current_thread->m_search_regs_saved)
+
+ struct re_registers m_saved_search_regs;
+#define saved_search_regs (current_thread->m_saved_search_regs)
+
+ /* This is the string or buffer in which we
+ are matching. It is used for looking up syntax properties.
+
+ If the value is a Lisp string object, we are matching text in that
+ string; if it's nil, we are matching text in the current buffer; if
+ it's t, we are matching text in a C string. */
+ Lisp_Object m_re_match_object;
+#define re_match_object (current_thread->m_re_match_object)
+
+ /* This variable is different from waiting_for_input in keyboard.c.
+ It is used to communicate to a lisp process-filter/sentinel (via the
+ function Fwaiting_for_user_input_p) whether Emacs was waiting
+ for user-input when that process-filter was called.
+ waiting_for_input cannot be used as that is by definition 0 when
+ lisp code is being evalled.
+ This is also used in record_asynch_buffer_change.
+ For that purpose, this must be 0
+ when not inside wait_reading_process_output. */
+ int m_waiting_for_user_input_p;
+#define waiting_for_user_input_p (current_thread->m_waiting_for_user_input_p)
+
+ /* The OS identifier for this thread. */
+ sys_thread_t thread_id;
+
+ /* The condition variable for this thread. This is associated with
+ the global lock. This thread broadcasts to it when it exits. */
+ sys_cond_t thread_condvar;
+
+ /* This thread might be waiting for some condition. If so, this
+ points to the condition. If the thread is interrupted, the
+ interrupter should broadcast to this condition. */
+ sys_cond_t *wait_condvar;
+
+ /* Threads are kept on a linked list. */
+ struct thread_state *next_thread;
+};
+
+/* A mutex in lisp is represented by a system condition variable.
+ The system mutex associated with this condition variable is the
+ global lock.
+
+ Using a condition variable lets us implement interruptibility for
+ lisp mutexes. */
+typedef struct
+{
+ /* The owning thread, or NULL if unlocked. */
+ struct thread_state *owner;
+ /* The lock count. */
+ unsigned int count;
+ /* The underlying system condition variable. */
+ sys_cond_t condition;
+} lisp_mutex_t;
+
+/* A mutex as a lisp object. */
+struct Lisp_Mutex
+{
+ struct vectorlike_header header;
+
+ /* The name of the mutex, or nil. */
+ Lisp_Object name;
+
+ /* The lower-level mutex object. */
+ lisp_mutex_t mutex;
+};
+
+/* A condition variable as a lisp object. */
+struct Lisp_CondVar
+{
+ struct vectorlike_header header;
+
+ /* The associated mutex. */
+ Lisp_Object mutex;
+
+ /* The name of the condition variable, or nil. */
+ Lisp_Object name;
+
+ /* The lower-level condition variable object. */
+ sys_cond_t cond;
+};
+
+extern struct thread_state *current_thread;
+
+extern void unmark_threads (void);
+extern void finalize_one_thread (struct thread_state *state);
+extern void finalize_one_mutex (struct Lisp_Mutex *);
+extern void finalize_one_condvar (struct Lisp_CondVar *);
+
+extern void init_threads_once (void);
+extern void init_threads (void);
+extern void syms_of_threads (void);
+
+typedef int select_func (int, fd_set *, fd_set *, fd_set *,
+ const struct timespec *, const sigset_t *);
+
+int thread_select (select_func *func, int max_fds, fd_set *rfds,
+ fd_set *wfds, fd_set *efds, struct timespec *timeout,
+ sigset_t *sigmask);
+
+bool thread_check_current_buffer (struct buffer *);
+
+#endif /* THREAD_H */
diff --git a/src/w32.c b/src/w32.c
index fa7fec7..e96f297 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -272,7 +272,7 @@ static BOOL WINAPI revert_to_self (void);
static int sys_access (const char *, int);
extern void *e_malloc (size_t);
extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *,
- struct timespec *, void *);
+ const struct timespec *, const sigset_t *);
extern int sys_dup (int);
diff --git a/src/w32proc.c b/src/w32proc.c
index 189034c..6f3a6e0 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -72,7 +72,7 @@ extern BOOL g_b_init_compare_string_w;
extern BOOL g_b_init_debug_break_process;
int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *,
- struct timespec *, void *);
+ const struct timespec *, const sigset_t *);
/* Signal handlers...SIG_DFL == 0 so this is initialized correctly. */
static signal_handler sig_handlers[NSIG];
@@ -849,8 +849,8 @@ alarm (int seconds)
stream is terminated, terminates the reader thread as part of
deleting the child_process object.
- The sys_select function emulates the Posix 'pselect' function; it
- is needed because the Windows 'select' function supports only
+ The sys_select function emulates the Posix 'pselect' functionality;
+ it is needed because the Windows 'select' function supports only
network sockets, while Emacs expects 'pselect' to work for any file
descriptor, including pipes and serial streams.
@@ -2096,7 +2096,7 @@ extern int proc_buffered_char[];
int
sys_select (int nfds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds,
- struct timespec *timeout, void *ignored)
+ const struct timespec *timeout, const sigset_t *ignored)
{
SELECT_TYPE orfds, owfds;
DWORD timeout_ms, start_time;
diff --git a/src/window.c b/src/window.c
index e8798f1..c3e6931 100644
--- a/src/window.c
+++ b/src/window.c
@@ -6008,7 +6008,7 @@ struct save_window_data
struct vectorlike_header header;
Lisp_Object selected_frame;
Lisp_Object current_window;
- Lisp_Object current_buffer;
+ Lisp_Object f_current_buffer;
Lisp_Object minibuf_scroll_window;
Lisp_Object minibuf_selected_window;
Lisp_Object root_window;
@@ -6098,7 +6098,7 @@ the return value is nil. Otherwise the value is t. */)
data = (struct save_window_data *) XVECTOR (configuration);
saved_windows = XVECTOR (data->saved_windows);
- new_current_buffer = data->current_buffer;
+ new_current_buffer = data->f_current_buffer;
if (!BUFFER_LIVE_P (XBUFFER (new_current_buffer)))
new_current_buffer = Qnil;
else
@@ -6750,7 +6750,7 @@ saved by this function. */)
data->frame_tool_bar_height = FRAME_TOOL_BAR_HEIGHT (f);
data->selected_frame = selected_frame;
data->current_window = FRAME_SELECTED_WINDOW (f);
- XSETBUFFER (data->current_buffer, current_buffer);
+ XSETBUFFER (data->f_current_buffer, current_buffer);
data->minibuf_scroll_window = minibuf_level > 0 ? Vminibuf_scroll_window :
Qnil;
data->minibuf_selected_window = minibuf_level > 0 ? minibuf_selected_window
: Qnil;
data->root_window = FRAME_ROOT_WINDOW (f);
@@ -7205,7 +7205,7 @@ compare_window_configurations (Lisp_Object configuration1,
|| d1->frame_lines != d2->frame_lines
|| d1->frame_menu_bar_lines != d2->frame_menu_bar_lines
|| !EQ (d1->selected_frame, d2->selected_frame)
- || !EQ (d1->current_buffer, d2->current_buffer)
+ || !EQ (d1->f_current_buffer, d2->f_current_buffer)
|| (!ignore_positions
&& (!EQ (d1->minibuf_scroll_window, d2->minibuf_scroll_window)
|| !EQ (d1->minibuf_selected_window,
d2->minibuf_selected_window)))
diff --git a/src/xgselect.c b/src/xgselect.c
index 7850a16..2f23764 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,
int gfds_size = ARRAYELTS (gfds_buf);
int n_gfds, retval = 0, our_fds = 0, max_fds = fds_lim - 1;
bool context_acquired = false;
- int i, nfds, tmo_in_millisec;
+ int i, nfds, tmo_in_millisec, must_free = 0;
bool need_to_dispatch;
- USE_SAFE_ALLOCA;
context = g_main_context_default ();
context_acquired = g_main_context_acquire (context);
@@ -77,7 +76,11 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set
*efds,
if (gfds_size < n_gfds)
{
- SAFE_NALLOCA (gfds, sizeof *gfds, n_gfds);
+ /* Avoid using SAFE_NALLOCA, as that implicitly refers to the
+ current thread. Using xnmalloc avoids thread-switching
+ problems here. */
+ gfds = xnmalloc (n_gfds, sizeof *gfds);
+ must_free = 1;
gfds_size = n_gfds;
n_gfds = g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec,
gfds, gfds_size);
@@ -98,7 +101,8 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set
*efds,
}
}
- SAFE_FREE ();
+ if (must_free)
+ xfree (gfds);
if (n_gfds >= 0 && tmo_in_millisec >= 0)
{
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index 4c2ea54..de0b8e6 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -256,6 +256,87 @@ comparing the subr with a much slower lisp implementation."
(v3 (bool-vector-not v1)))
(should (equal v2 v3))))
+;; Tests for variable bindings
+
+(defvar binding-test-buffer-A (get-buffer-create "A"))
+(defvar binding-test-buffer-B (get-buffer-create "B"))
+
+(defvar binding-test-always-local 'always)
+(make-variable-buffer-local 'binding-test-always-local)
+
+(defvar binding-test-some-local 'some)
+(with-current-buffer binding-test-buffer-A
+ (set (make-local-variable 'binding-test-some-local) 'local))
+
+(ert-deftest binding-test-manual ()
+ "A test case from the elisp manual."
+ (save-excursion
+ (set-buffer binding-test-buffer-A)
+ (let ((binding-test-some-local 'something-else))
+ (should (eq binding-test-some-local 'something-else))
+ (set-buffer binding-test-buffer-B)
+ (should (eq binding-test-some-local 'some)))
+ (should (eq binding-test-some-local 'some))
+ (set-buffer binding-test-buffer-A)
+ (should (eq binding-test-some-local 'local))))
+
+(ert-deftest binding-test-setq-default ()
+ "Test that a setq-default has no effect when there is a local binding."
+ (save-excursion
+ (set-buffer binding-test-buffer-B)
+ ;; This variable is not local in this buffer.
+ (let ((binding-test-some-local 'something-else))
+ (setq-default binding-test-some-local 'new-default))
+ (should (eq binding-test-some-local 'some))))
+
+(ert-deftest binding-test-makunbound ()
+ "Tests of makunbound, from the manual."
+ (save-excursion
+ (set-buffer binding-test-buffer-B)
+ (should (boundp 'binding-test-some-local))
+ (let ((binding-test-some-local 'outer))
+ (let ((binding-test-some-local 'inner))
+ (makunbound 'binding-test-some-local)
+ (should (not (boundp 'binding-test-some-local))))
+ (should (and (boundp 'binding-test-some-local)
+ (eq binding-test-some-local 'outer))))))
+
+(ert-deftest binding-test-defvar-bool ()
+ "Test DEFVAR_BOOL"
+ (let ((display-hourglass 5))
+ (should (eq display-hourglass t))))
+
+(ert-deftest binding-test-defvar-int ()
+ "Test DEFVAR_INT"
+ (should-error (setq gc-cons-threshold 5.0) :type 'wrong-type-argument))
+
+(ert-deftest binding-test-set-constant-t ()
+ "Test setting the constant t"
+ (should-error (setq t 'bob) :type 'setting-constant))
+
+(ert-deftest binding-test-set-constant-nil ()
+ "Test setting the constant nil"
+ (should-error (setq nil 'bob) :type 'setting-constant))
+
+(ert-deftest binding-test-set-constant-keyword ()
+ "Test setting a keyword constant"
+ (should-error (setq :keyword 'bob) :type 'setting-constant))
+
+(ert-deftest binding-test-set-constant-nil ()
+ "Test setting a keyword to itself"
+ (should (setq :keyword :keyword)))
+
+;; More tests to write -
+;; kill-local-variable
+;; defconst; can modify
+;; defvar and defconst modify the local binding [ doesn't matter for us ]
+;; various kinds of special internal forwarding objects
+;; a couple examples in manual, not enough
+;; frame-local vars
+;; variable aliases
+
+;; Tests for watchpoints
+
(ert-deftest data-tests-variable-watchers ()
(defvar data-tests-var 0)
(let* ((watch-data nil)
diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el
new file mode 100644
index 0000000..c65b642
--- /dev/null
+++ b/test/src/thread-tests.el
@@ -0,0 +1,213 @@
+;;; threads.el --- tests for threads.
+
+;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(ert-deftest threads-is-one ()
+ "test for existence of a thread"
+ (should (current-thread)))
+
+(ert-deftest threads-threadp ()
+ "test of threadp"
+ (should (threadp (current-thread))))
+
+(ert-deftest threads-type ()
+ "test of thread type"
+ (should (eq (type-of (current-thread)) 'thread)))
+
+(ert-deftest threads-name ()
+ "test for name of a thread"
+ (should
+ (string= "hi bob" (thread-name (make-thread #'ignore "hi bob")))))
+
+(ert-deftest threads-alive ()
+ "test for thread liveness"
+ (should
+ (thread-alive-p (make-thread #'ignore))))
+
+(ert-deftest threads-all-threads ()
+ "simple test for all-threads"
+ (should (listp (all-threads))))
+
+(defvar threads-test-global nil)
+
+(defun threads-test-thread1 ()
+ (setq threads-test-global 23))
+
+(ert-deftest threads-basic ()
+ "basic thread test"
+ (should
+ (progn
+ (setq threads-test-global nil)
+ (make-thread #'threads-test-thread1)
+ (while (not threads-test-global)
+ (thread-yield))
+ threads-test-global)))
+
+(ert-deftest threads-join ()
+ "test of thread-join"
+ (should
+ (progn
+ (setq threads-test-global nil)
+ (let ((thread (make-thread #'threads-test-thread1)))
+ (thread-join thread)
+ (and threads-test-global
+ (not (thread-alive-p thread)))))))
+
+(ert-deftest threads-join-self ()
+ "cannot thread-join the current thread"
+ (should-error (thread-join (current-thread))))
+
+(defvar threads-test-binding nil)
+
+(defun threads-test-thread2 ()
+ (let ((threads-test-binding 23))
+ (thread-yield))
+ (setq threads-test-global 23))
+
+(ert-deftest threads-let-binding ()
+ "simple test of threads and let bindings"
+ (should
+ (progn
+ (setq threads-test-global nil)
+ (make-thread #'threads-test-thread2)
+ (while (not threads-test-global)
+ (thread-yield))
+ (and (not threads-test-binding)
+ threads-test-global))))
+
+(ert-deftest threads-mutexp ()
+ "simple test of mutexp"
+ (should-not (mutexp 'hi)))
+
+(ert-deftest threads-mutexp-2 ()
+ "another simple test of mutexp"
+ (should (mutexp (make-mutex))))
+
+(ert-deftest threads-mutex-type ()
+ "type-of mutex"
+ (should (eq (type-of (make-mutex)) 'mutex)))
+
+(ert-deftest threads-mutex-lock-unlock ()
+ "test mutex-lock and unlock"
+ (should
+ (let ((mx (make-mutex)))
+ (mutex-lock mx)
+ (mutex-unlock mx)
+ t)))
+
+(ert-deftest threads-mutex-recursive ()
+ "test mutex-lock and unlock"
+ (should
+ (let ((mx (make-mutex)))
+ (mutex-lock mx)
+ (mutex-lock mx)
+ (mutex-unlock mx)
+ (mutex-unlock mx)
+ t)))
+
+(defvar threads-mutex nil)
+(defvar threads-mutex-key nil)
+
+(defun threads-test-mlock ()
+ (mutex-lock threads-mutex)
+ (setq threads-mutex-key 23)
+ (while threads-mutex-key
+ (thread-yield))
+ (mutex-unlock threads-mutex))
+
+(ert-deftest threads-mutex-contention ()
+ "test of mutex contention"
+ (should
+ (progn
+ (setq threads-mutex (make-mutex))
+ (setq threads-mutex-key nil)
+ (make-thread #'threads-test-mlock)
+ ;; Wait for other thread to get the lock.
+ (while (not threads-mutex-key)
+ (thread-yield))
+ ;; Try now.
+ (setq threads-mutex-key nil)
+ (mutex-lock threads-mutex)
+ (mutex-unlock threads-mutex)
+ t)))
+
+(defun threads-test-mlock2 ()
+ (setq threads-mutex-key 23)
+ (mutex-lock threads-mutex))
+
+(ert-deftest threads-mutex-signal ()
+ "test signalling a blocked thread"
+ (should
+ (progn
+ (setq threads-mutex (make-mutex))
+ (setq threads-mutex-key nil)
+ (mutex-lock threads-mutex)
+ (let ((thr (make-thread #'threads-test-mlock2)))
+ (while (not threads-mutex-key)
+ (thread-yield))
+ (thread-signal thr 'quit nil)
+ (thread-join thr))
+ t)))
+
+(defun threads-test-io-switch ()
+ (setq threads-test-global 23))
+
+(ert-deftest threads-io-switch ()
+ "test that accept-process-output causes thread switch"
+ (should
+ (progn
+ (setq threads-test-global nil)
+ (make-thread #'threads-test-io-switch)
+ (while (not threads-test-global)
+ (accept-process-output nil 1))
+ threads-test-global)))
+
+(ert-deftest threads-condvarp ()
+ "simple test of condition-variable-p"
+ (should-not (condition-variable-p 'hi)))
+
+(ert-deftest threads-condvarp-2 ()
+ "another simple test of condition-variable-p"
+ (should (condition-variable-p (make-condition-variable (make-mutex)))))
+
+(ert-deftest threads-condvar-type ()
+ "type-of condvar"
+ (should (eq (type-of (make-condition-variable (make-mutex)))
+ 'condition-variable)))
+
+(ert-deftest threads-condvar-mutex ()
+ "simple test of condition-mutex"
+ (should
+ (let ((m (make-mutex)))
+ (eq m (condition-mutex (make-condition-variable m))))))
+
+(ert-deftest threads-condvar-name ()
+ "simple test of condition-name"
+ (should
+ (eq nil (condition-name (make-condition-variable (make-mutex))))))
+
+(ert-deftest threads-condvar-name-2 ()
+ "another simple test of condition-name"
+ (should
+ (string= "hi bob"
+ (condition-name (make-condition-variable (make-mutex)
+ "hi bob")))))
+
+;;; threads.el ends here