procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Support concurrency in Emacs Lisp

Browse source 
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.
This commit is contained in:
Eli Zaretskii 2016-12-10 18:54:43 +02:00
commit 2412a1fc05
37 changed files with 3497 additions and 452 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
configure.ac
View file

@ -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

1
doc/lispref/Makefile.in
View file

@ -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 \

11
doc/lispref/elisp.texi
View file

@ -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
@include threads.texi
@include processes.texi
@include display.texi

89
doc/lispref/objects.texi
View file

@ -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.
@node Thread Type
@subsection 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:
@example
@group
(all-threads)
@result{} (#<thread 0176fc40>)
@end group
@end example
@node Mutex Type
@subsection 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:
@example
@group
(make-mutex "my-mutex")
@result{} #<mutex my-mutex>
(make-mutex)
@result{} #<mutex 01c7e4e0>
@end group
@end example
@node Condition Variable Type
@subsection 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:
@example
@group
(make-condition-variable (make-mutex))
@result{} #<condvar 01c45ae8>
@end group
@end example
@node Stream Type
@subsection Stream Type
@ -1830,6 +1890,9 @@ with references to further information.
@item commandp
@xref{Interactive Call, commandp}.
@item condition-variable-p
@xref{Condition 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}.
@item mutexp
@xref{Mutexes, 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}.
@item threadp
@xref{Basic 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}.
@item threadp
@xref{Basic Thread Functions, threadp}.
@item mutexp
@xref{Mutexes, mutexp}.
@item condition-variable-p
@xref{Condition 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},
@code{cons}, @code{finalizer}, @code{float}, @code{font-entity},
@code{font-object}, @code{font-spec}, @code{frame}, @code{hash-table},
@code{integer}, @code{marker}, @code{overlay}, @code{process},
@code{string}, @code{subr}, @code{symbol}, @code{vector},
@code{window}, or @code{window-configuration}.
@code{condition-variable}, @code{cons}, @code{finalizer},
@code{float}, @code{font-entity}, @code{font-object},
@code{font-spec}, @code{frame}, @code{hash-table}, @code{integer},
@code{marker}, @code{mutex}, @code{overlay}, @code{process},
@code{string}, @code{subr}, @code{symbol}, @code{thread},
@code{vector}, @code{window}, or @code{window-configuration}.
@example
(type-of 1)

30
doc/lispref/processes.texi
View file

@ -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
@node Processes and Threads
@subsection Processes and Threads
@cindex 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
@code{accept-process-output}, 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
@code{accept-process-output} or @code{sit-for} returns.
If the thread exits, all the processes locked to it are unlocked.
@defun process-thread process
Return the thread to which @var{process} is locked. If @var{process}
is unlocked, return @code{nil}.
@end defun
@defun 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.
@end defun
@node Sentinels
@section Sentinels: Detecting Process Status Changes
@cindex process sentinel

252
doc/lispref/threads.texi Normal file
View file

@ -0,0 +1,252 @@
@c -*-texinfo-*-
@c This is part of the GNU Emacs Lisp Reference Manual.
@c Copyright (C) 2012, 2013
@c Free Software Foundation, Inc.
@c See the file elisp.texi for copying conditions.
@node Threads
@chapter Threads
@cindex threads
@cindex concurrency
Emacs Lisp provides a limited form of concurrency, called
@dfn{threads}. 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
@code{thread-yield}, 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
@code{thread-join}.
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
@code{unwind-protect} 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.
@menu
* Basic Thread Functions:: Basic thread functions.
* Mutexes:: Mutexes allow exclusive access to data.
* Condition Variables:: Inter-thread events.
@end menu
@node Basic Thread Functions
@section 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.
@defun make-thread function &optional name
Create a new thread of execution which invokes @var{function}. When
@var{function} 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.
@var{name} 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.
@end defun
@defun threadp object
This function returns @code{t} if @var{object} represents an Emacs
thread, @code{nil} otherwise.
@end defun
@defun thread-join thread
Block until @var{thread} exits, or until the current thread is
signaled. If @var{thread} has already exited, this returns
immediately.
@end defun
@defun 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.
@code{thread-signal} will cause a thread to exit a call to
@code{mutex-lock}, @code{condition-wait}, or @code{thread-join}.
@end defun
@defun thread-yield
Yield execution to the next runnable thread.
@end defun
@defun thread-name thread
Return the name of @var{thread}, as specified to @code{make-thread}.
@end defun
@defun 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.
@end defun
@defun 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}.
@end defun
@defun current-thread
Return the current thread.
@end defun
@defun all-threads
Return a list of all the live thread objects. A new list is returned
by each invocation.
@end defun
@node Mutexes
@section 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.
@defun mutexp object
This function returns @code{t} if @var{object} represents an Emacs
mutex, @code{nil} otherwise.
@end defun
@defun 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.
@end defun
@defun mutex-name mutex
Return the name of @var{mutex}, as specified to @code{make-mutex}.
@end defun
@defun 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.
@end defun
@defun mutex-unlock mutex
Release @var{mutex}. If @var{mutex} is not owned by this thread, this
will signal an error.
@end defun
@defmac with-mutex mutex body@dots{}
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}.
@end defmac
@node Condition Variables
@section 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:
@example
(with-mutex mutex
(while (not global-variable)
(condition-wait cond-var)))
@end 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:
@example
(with-mutex mutex
(setq global-variable (some-computation))
(condition-notify cond-var))
@end example
@defun make-condition-variable mutex &optional name
Make a new condition variable associated with @var{mutex}. If
@var{name} 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.
@end defun
@defun condition-variable-p object
This function returns @code{t} if @var{object} represents a condition
variable, @code{nil} otherwise.
@end defun
@defun 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.
@code{condition-wait} releases the associated mutex while waiting.
This allows other threads to acquire the mutex in order to notify the
condition.
@end defun
@defun 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
@code{condition-notify}; but if @var{all} is not @code{nil}, then all
threads waiting on @var{cond} are notified.
@code{condition-notify} releases the associated mutex while waiting.
This allows other threads to acquire the mutex in order to wait on the
condition.
@c why bother?
@end defun
@defun condition-name cond
Return the name of @var{cond}, as passed to
@code{make-condition-variable}.
@end defun
@defun condition-mutex cond
Return the mutex associated with @var{cond}. Note that the associated
mutex cannot be changed.
@end defun

2
etc/DEBUG
View file

@ -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

13
etc/NEWS
View file

@ -73,6 +73,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.

14
lisp/subr.el
View file

@ -4952,6 +4952,20 @@ as a list.")
(match-string 1 subdir) subdir))
"-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.

1
nt/inc/sys/socket.h
View file

@ -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

15
src/.gdbinit
View file

@ -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 ()

1
src/Makefile.in
View file

@ -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)

110
src/alloc.c
View file

@ -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);

5
src/buffer.c
View file

@ -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 ();

4
src/buffer.h
View file

@ -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

203
src/bytecode.c
View file

@ -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
/* 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;
}
}
}
/* Fetch the next byte from the bytecode stream. */
#define FETCH (*pc++)
#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)
{

39
src/data.c
View file

@ -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);

14
src/emacs.c
View file

@ -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 ();

268
src/eval.c
View file

@ -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)
{
@ -121,6 +130,13 @@ specpdl_where (union specbinding *pdl)
return pdl->let.where;
}
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)
{
@ -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--;
union specbinding this_binding;
this_binding = *--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));
/* 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:

162
src/lisp.h
View file

@ -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);

36
src/print.c
View file

@ -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);

547
src/process.c
View file

@ -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);

5
src/process.h
View file

@ -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 */

6
src/regex.c
View file

@ -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

8
src/regex.h
View file

@ -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. */

22
src/search.c
View file

@ -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]);
}

9
src/sysdep.c
View file

@ -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>

417
src/systhread.c Normal file
View file

@ -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

112
src/systhread.h Normal file
View file

@ -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 */

970
src/thread.c Normal file
View file

@ -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, &current_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");
}

237
src/thread.h Normal file
View file

@ -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 */

2
src/w32.c
View file

@ -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);

8
src/w32proc.c
View file

@ -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;

8
src/window.c
View file

@ -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)))

12
src/xgselect.c
View file

@ -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)
{

81
test/src/data-tests.el
View file

@ -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)

213
test/src/thread-tests.el Normal file
View file

@ -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