diff options
| author | Eli Zaretskii <eliz@gnu.org> | 2016-12-04 19:59:17 +0200 |
|---|---|---|
| committer | Eli Zaretskii <eliz@gnu.org> | 2016-12-04 19:59:17 +0200 |
| commit | de4624c99ea5bbe38ad5aff7b6461cc5c740d0be (patch) | |
| tree | 1b57de9e769cdb695cb2cecf157b50f7dea9cfe5 | |
| parent | a486fabb41cdbaa5813c2687fd4008945297d71d (diff) | |
| parent | e7bde34e939451d87fb42a36195086bdbe48b5e1 (diff) | |
| download | emacs-de4624c99ea5bbe38ad5aff7b6461cc5c740d0be.tar.gz | |
Merge branch 'concurrency'
Conflicts (resolved):
configure.ac
src/Makefile.in
src/alloc.c
src/bytecode.c
src/emacs.c
src/eval.c
src/lisp.h
src/process.c
src/regex.c
src/regex.h
37 files changed, 3434 insertions, 449 deletions
diff --git a/configure.ac b/configure.ac index 2d116de3b6b..5aaf006c549 100644 --- a/configure.ac +++ b/configure.ac @@ -355,6 +355,7 @@ OPTION_DEFAULT_ON([selinux],[don't compile with SELinux support]) OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support]) OPTION_DEFAULT_ON([zlib],[don't compile with zlib decompression support]) OPTION_DEFAULT_OFF([modules],[compile with dynamic modules support]) +OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB], [use a file notification library (LIB one of: yes, inotify, kqueue, gfile, w32, no)])], @@ -1643,7 +1644,7 @@ AC_CHECK_HEADERS_ONCE( sys/sysinfo.h coff.h pty.h sys/resource.h - sys/utsname.h pwd.h utmp.h util.h) + sys/utsname.h pwd.h utmp.h util.h sys/prctl.h) AC_CACHE_CHECK([for ADDR_NO_RANDOMIZE], [emacs_cv_personality_addr_no_randomize], @@ -2305,6 +2306,22 @@ if test "$ac_cv_header_pthread_h" && test "$opsys" != "mingw32"; then fi AC_SUBST([LIB_PTHREAD]) +AC_MSG_CHECKING([for thread support]) +threads_enabled=no +if test "$with_threads" = yes; then + if test "$emacs_cv_pthread_lib" != no; then + AC_DEFINE(THREADS_ENABLED, 1, + [Define to 1 if you want elisp thread support.]) + threads_enabled=yes + elif test "${opsys}" = "mingw32"; then + dnl MinGW can do native Windows threads even without pthreads + AC_DEFINE(THREADS_ENABLED, 1, + [Define to 1 if you want elisp thread support.]) + threads_enabled=yes + fi +fi +AC_MSG_RESULT([$threads_enabled]) + dnl Check for need for bigtoc support on IBM AIX case ${host_os} in @@ -3871,7 +3888,7 @@ pthread_sigmask strsignal setitimer \ sendto recvfrom getsockname getifaddrs freeifaddrs \ gai_strerror sync \ getpwent endpwent getgrent endgrent \ -cfmakeraw cfsetspeed copysign __executable_start log2) +cfmakeraw cfsetspeed copysign __executable_start log2 prctl) LIBS=$OLD_LIBS dnl No need to check for posix_memalign if aligned_alloc works. @@ -5314,6 +5331,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs have dynamic modules support? ${HAVE_MODULES} Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS} Does Emacs support Xwidgets (requires gtk3)? ${HAVE_XWIDGETS} + Does Emacs have threading support in lisp? ${threads_enabled} "]) if test -n "${EMACSDATA}"; then diff --git a/doc/lispref/Makefile.in b/doc/lispref/Makefile.in index 7aadee7adea..5bf6e99d587 100644 --- a/doc/lispref/Makefile.in +++ b/doc/lispref/Makefile.in @@ -125,6 +125,7 @@ srcs = \ $(srcdir)/symbols.texi \ $(srcdir)/syntax.texi \ $(srcdir)/text.texi \ + $(srcdir)/threads.texi \ $(srcdir)/tips.texi \ $(srcdir)/variables.texi \ $(srcdir)/windows.texi \ diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 6983ab77c63..415dbe66fac 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -219,6 +219,7 @@ To view this manual in other formats, click * Syntax Tables:: The syntax table controls word and list parsing. * Abbrevs:: How Abbrev mode works, and its data structures. +* Threads:: Concurrency in Emacs Lisp. * Processes:: Running and communicating with subprocesses. * Display:: Features for controlling the screen display. * System Interface:: Getting the user id, system type, environment @@ -1322,6 +1323,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 +1635,7 @@ Object Internals @include searching.texi @include syntax.texi @include abbrevs.texi +@include threads.texi @include processes.texi @include display.texi diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 54894b8e24e..a76fbb1af7f 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -1925,6 +1925,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 +1947,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) diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 21e1429f59d..064934cc662 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -1400,6 +1400,7 @@ Emacs tries to read it. * Filter Functions:: Filter functions accept output from the process. * Decoding Output:: Filters can get unibyte or multibyte strings. * Accepting Output:: How to wait until process output arrives. +* Processes and Threads:: How processes and threads interact. @end menu @node Process Buffers @@ -1791,6 +1792,35 @@ got output from @var{process}, or from any process if @var{process} is arrived. @end defun +@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 diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi new file mode 100644 index 00000000000..6237392db3a --- /dev/null +++ b/doc/lispref/threads.texi @@ -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 diff --git a/etc/DEBUG b/etc/DEBUG index 03efa3b10dd..ddec7b4414d 100644 --- a/etc/DEBUG +++ b/etc/DEBUG @@ -313,7 +313,7 @@ type. Here are these commands: xbufobjfwd xkbobjfwd xbuflocal xbuffer xsymbol xstring xvector xframe xwinconfig xcompiled xcons xcar xcdr xsubr xprocess xfloat xscrollbar xchartable xsubchartable xboolvector xhashtable xlist xcoding - xcharset xfontset xfont + xcharset xfontset xfont xbytecode Each one of them applies to a certain type or class of types. (Some of these types are not visible in Lisp, because they exist only diff --git a/lisp/subr.el b/lisp/subr.el index 5da5bf8388a..1502bed3e4d 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4952,6 +4952,20 @@ as a list.") "-pkg.el")) +;;; Thread support. + +(defmacro with-mutex (mutex &rest body) + "Invoke BODY with MUTEX held, releasing MUTEX when done. +This is the simplest safe way to acquire and release a mutex." + (declare (indent 1) (debug t)) + (let ((sym (make-symbol "mutex"))) + `(let ((,sym ,mutex)) + (mutex-lock ,sym) + (unwind-protect + (progn ,@body) + (mutex-unlock ,sym))))) + + ;;; Misc. (defvar definition-prefixes (make-hash-table :test 'equal) diff --git a/nt/inc/sys/socket.h b/nt/inc/sys/socket.h index 6b9f56f917c..e9a021a5038 100644 --- a/nt/inc/sys/socket.h +++ b/nt/inc/sys/socket.h @@ -53,6 +53,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <ws2tcpip.h> /* process.c uses uint16_t (from C99) for IPv6, but apparently it is not defined in some versions of mingw and msvc. */ +#include <stdint.h> #ifndef UINT16_C typedef unsigned short uint16_t; #endif diff --git a/src/.gdbinit b/src/.gdbinit index b0c0dfd7e90..9160ffa439e 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -1215,6 +1215,21 @@ document xwhichsymbols maximum number of symbols referencing it to produce. end +define xbytecode + set $bt = byte_stack_list + while $bt + xgetptr $bt->byte_string + set $ptr = (struct Lisp_String *) $ptr + xprintbytestr $ptr + printf "\n0x%x => ", $bt->byte_string + xwhichsymbols $bt->byte_string 5 + set $bt = $bt->next + end +end +document xbytecode + Print a backtrace of the byte code stack. +end + # Show Lisp backtrace after normal backtrace. define hookpost-backtrace set $bt = backtrace_top () diff --git a/src/Makefile.in b/src/Makefile.in index dc0bfff9b33..a8c12848cee 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -409,6 +409,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ doprnt.o intervals.o textprop.o composite.o xml.o $(NOTIFY_OBJ) \ $(XWIDGETS_OBJ) \ profiler.o decompress.o \ + thread.o systhread.o \ $(if $(HYBRID_MALLOC),sheap.o) \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) diff --git a/src/alloc.c b/src/alloc.c index 6eced7bab18..f2b7682b05d 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -438,10 +438,6 @@ struct mem_node enum mem_type type; }; -/* Base address of stack. Set in main. */ - -Lisp_Object *stack_base; - /* Root of the tree describing allocated Lisp memory. */ static struct mem_node *mem_root; @@ -3190,8 +3186,7 @@ vector_nbytes (struct Lisp_Vector *v) } /* Release extra resources still in use by VECTOR, which may be any - vector-like object. For now, this is used just to free data in - font objects. */ + vector-like object. */ static void cleanup_vector (struct Lisp_Vector *vector) @@ -3212,6 +3207,13 @@ cleanup_vector (struct Lisp_Vector *vector) drv->close ((struct font *) vector); } } + + if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD)) + finalize_one_thread ((struct thread_state *) vector); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX)) + finalize_one_mutex ((struct Lisp_Mutex *) vector); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR)) + finalize_one_condvar ((struct Lisp_CondVar *) vector); } /* Reclaim space used by unmarked vectors. */ @@ -5047,14 +5049,13 @@ test_setjmp (void) would be necessary, each one starting with one byte more offset from the stack start. */ -static void -mark_stack (void *end) +void +mark_stack (char *bottom, char *end) { - /* This assumes that the stack is a contiguous region in memory. If that's not the case, something has to be done here to iterate over the stack segments. */ - mark_memory (stack_base, end); + mark_memory (bottom, end); /* Allow for marking a secondary stack, like the register stack on the ia64. */ @@ -5063,6 +5064,81 @@ mark_stack (void *end) #endif } +/* This is a trampoline function that flushes registers to the stack, + and then calls FUNC. ARG is passed through to FUNC verbatim. + + This function must be called whenever Emacs is about to release the + global interpreter lock. This lets the garbage collector easily + find roots in registers on threads that are not actively running + Lisp. + + It is invalid to run any Lisp code or to allocate any GC memory + from FUNC. */ + +void +flush_stack_call_func (void (*func) (void *arg), void *arg) +{ + void *end; + struct thread_state *self = current_thread; + +#ifdef HAVE___BUILTIN_UNWIND_INIT + /* Force callee-saved registers and register windows onto the stack. + This is the preferred method if available, obviating the need for + machine dependent methods. */ + __builtin_unwind_init (); + end = &end; +#else /* not HAVE___BUILTIN_UNWIND_INIT */ +#ifndef GC_SAVE_REGISTERS_ON_STACK + /* jmp_buf may not be aligned enough on darwin-ppc64 */ + union aligned_jmpbuf { + Lisp_Object o; + sys_jmp_buf j; + } j; + volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom; +#endif + /* This trick flushes the register windows so that all the state of + the process is contained in the stack. */ + /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is + needed on ia64 too. See mach_dep.c, where it also says inline + assembler doesn't work with relevant proprietary compilers. */ +#ifdef __sparc__ +#if defined (__sparc64__) && defined (__FreeBSD__) + /* FreeBSD does not have a ta 3 handler. */ + asm ("flushw"); +#else + asm ("ta 3"); +#endif +#endif + + /* Save registers that we need to see on the stack. We need to see + registers used to hold register variables and registers used to + pass parameters. */ +#ifdef GC_SAVE_REGISTERS_ON_STACK + GC_SAVE_REGISTERS_ON_STACK (end); +#else /* not GC_SAVE_REGISTERS_ON_STACK */ + +#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that + setjmp will definitely work, test it + and print a message with the result + of the test. */ + if (!setjmp_tested_p) + { + setjmp_tested_p = 1; + test_setjmp (); + } +#endif /* GC_SETJMP_WORKS */ + + sys_setjmp (j.j); + end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j; +#endif /* not GC_SAVE_REGISTERS_ON_STACK */ +#endif /* not HAVE___BUILTIN_UNWIND_INIT */ + + self->stack_top = end; + (*func) (arg); + + eassert (current_thread == self); +} + static bool c_symbol_p (struct Lisp_Symbol *sym) { @@ -5768,24 +5844,14 @@ garbage_collect_1 (void *end) mark_object (*staticvec[i]); mark_pinned_symbols (); - mark_specpdl (); mark_terminals (); mark_kboards (); + mark_threads (); #ifdef USE_GTK xg_mark_data (); #endif - mark_stack (end); - - { - struct handler *handler; - for (handler = handlerlist; handler; handler = handler->next) - { - mark_object (handler->tag_or_ch); - mark_object (handler->val); - } - } #ifdef HAVE_WINDOW_SYSTEM mark_fringe_data (); #endif @@ -5817,6 +5883,8 @@ garbage_collect_1 (void *end) gc_sweep (); + unmark_threads (); + /* Clear the mark bits that we set in certain root slots. */ VECTOR_UNMARK (&buffer_defaults); VECTOR_UNMARK (&buffer_local_symbols); diff --git a/src/buffer.c b/src/buffer.c index 6815aa7f7ed..cea1ddb5ab3 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -48,8 +48,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "w32heap.h" /* for mmap_* */ #endif -struct buffer *current_buffer; /* The current buffer. */ - /* First buffer in chain of all buffers (in reverse order of creation). Threaded through ->header.next.buffer. */ @@ -1654,6 +1652,9 @@ cleaning up all windows currently displaying the buffer to be killed. */) if (!BUFFER_LIVE_P (b)) return Qnil; + if (thread_check_current_buffer (b)) + return Qnil; + /* Run hooks with the buffer to be killed the current buffer. */ { ptrdiff_t count = SPECPDL_INDEX (); diff --git a/src/buffer.h b/src/buffer.h index 6ac161c1c91..21ad5e3bc0f 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -1040,10 +1040,6 @@ extern struct buffer *all_buffers; #define FOR_EACH_BUFFER(b) \ for ((b) = all_buffers; (b); (b) = (b)->next) -/* This points to the current buffer. */ - -extern struct buffer *current_buffer; - /* This structure holds the default values of the buffer-local variables that have special slots in each buffer. The default value occupies the same slot in this structure diff --git a/src/bytecode.c b/src/bytecode.c index 868c0148d30..3ac94055f33 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -280,10 +280,68 @@ enum byte_code_op Bset_mark = 0163, /* this loser is no longer generated as of v18 */ #endif }; + +/* Whether to maintain a `top' and `bottom' field in the stack frame. */ +#define BYTE_MAINTAIN_TOP BYTE_CODE_SAFE -/* Fetch the next byte from the bytecode stream. */ +/* Structure describing a value stack used during byte-code execution + in Fbyte_code. */ + +struct byte_stack +{ + /* Program counter. This points into the byte_string below + and is relocated when that string is relocated. */ + const unsigned char *pc; + + /* Top and bottom of stack. The bottom points to an area of memory + allocated with alloca in Fbyte_code. */ +#if BYTE_MAINTAIN_TOP + Lisp_Object *top, *bottom; +#endif + + /* The string containing the byte-code, and its current address. + Storing this here protects it from GC because mark_byte_stack + marks it. */ + Lisp_Object byte_string; + const unsigned char *byte_string_start; + + /* Next entry in byte_stack_list. */ + struct byte_stack *next; +}; + +/* A list of currently active byte-code execution value stacks. + Fbyte_code adds an entry to the head of this list before it starts + processing byte-code, and it removes the entry again when it is + done. Signaling an error truncates the list. + + byte_stack_list is a macro defined in thread.h. */ +/* struct byte_stack *byte_stack_list; */ + + +/* Relocate program counters in the stacks on byte_stack_list. Called + when GC has completed. */ + +void +relocate_byte_stack (struct byte_stack *stack) +{ + for (; stack; stack = stack->next) + { + if (stack->byte_string_start != SDATA (stack->byte_string)) + { + ptrdiff_t offset = stack->pc - stack->byte_string_start; + stack->byte_string_start = SDATA (stack->byte_string); + stack->pc = stack->byte_string_start + offset; + } + } +} -#define FETCH (*pc++) + +/* Fetch the next byte from the bytecode stream. */ +#ifdef BYTE_CODE_SAFE +#define FETCH (eassert (stack.byte_string_start == SDATA (stack.byte_string)), *stack.pc++) +#else +#define FETCH *stack.pc++ +#endif /* Fetch two bytes from the bytecode stream and make a 16-bit number out of them. */ @@ -308,6 +366,29 @@ enum byte_code_op #define TOP (*top) +#define CHECK_RANGE(ARG) \ + (BYTE_CODE_SAFE && bytestr_length <= (ARG) ? emacs_abort () : (void) 0) + +/* A version of the QUIT macro which makes sure that the stack top is + set before signaling `quit'. */ +#define BYTE_CODE_QUIT \ + do { \ + if (quitcounter++) \ + break; \ + maybe_gc (); \ + if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \ + { \ + Lisp_Object flag = Vquit_flag; \ + Vquit_flag = Qnil; \ + if (EQ (Vthrow_on_input, flag)) \ + Fthrow (Vthrow_on_input, Qt); \ + quit (); \ + } \ + else if (pending_signals) \ + process_pending_signals (); \ + } while (0) + + DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0, doc: /* Function used internally in byte-compiled code. The first argument, BYTESTR, is a string of byte code; @@ -357,18 +438,19 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, ptrdiff_t bytestr_length = SBYTES (bytestr); Lisp_Object *vectorp = XVECTOR (vector)->contents; + struct byte_stack stack; - unsigned char quitcounter = 1; + stack.byte_string = bytestr; + stack.pc = stack.byte_string_start = SDATA (bytestr); + unsigned char quitcounter = 0; EMACS_INT stack_items = XFASTINT (maxdepth) + 1; USE_SAFE_ALLOCA; Lisp_Object *stack_base; - SAFE_ALLOCA_LISP_EXTRA (stack_base, stack_items, bytestr_length); + SAFE_ALLOCA_LISP (stack_base, stack_items); Lisp_Object *stack_lim = stack_base + stack_items; Lisp_Object *top = stack_base; - memcpy (stack_lim, SDATA (bytestr), bytestr_length); - void *void_stack_lim = stack_lim; - unsigned char const *bytestr_data = void_stack_lim; - unsigned char const *pc = bytestr_data; + stack.next = byte_stack_list; + byte_stack_list = &stack; ptrdiff_t count = SPECPDL_INDEX (); if (!NILP (args_template)) @@ -508,10 +590,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bgotoifnil): { - Lisp_Object v1 = POP; + Lisp_Object v1; op = FETCH2; + v1 = POP; if (NILP (v1)) - goto op_branch; + { + BYTE_CODE_QUIT; + CHECK_RANGE (op); + stack.pc = stack.byte_string_start + op; + } NEXT; } @@ -666,72 +753,85 @@ 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; + } 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 +891,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (sys_setjmp (c->jmp)) { struct handler *c = handlerlist; + int desc; 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; @@ -1364,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): @@ -1424,6 +1528,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, exit: + byte_stack_list = byte_stack_list->next; + /* Binds and unbinds are supposed to be compiled balanced. */ if (SPECPDL_INDEX () != count) { diff --git a/src/data.c b/src/data.c index eee2a52a37a..711f67d1df1 100644 --- a/src/data.c +++ b/src/data.c @@ -258,6 +258,12 @@ for example, (type-of 1) returns `integer'. */) return Qfont_entity; if (FONT_OBJECT_P (object)) return Qfont_object; + if (THREADP (object)) + return Qthread; + if (MUTEXP (object)) + return Qmutex; + if (CONDVARP (object)) + return Qcondition_variable; return Qvector; case Lisp_Float: @@ -528,6 +534,33 @@ DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, return Qnil; } +DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0, + doc: /* Return t if OBJECT is a thread. */) + (Lisp_Object object) +{ + if (THREADP (object)) + return Qt; + return Qnil; +} + +DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0, + doc: /* Return t if OBJECT is a mutex. */) + (Lisp_Object object) +{ + if (MUTEXP (object)) + return Qt; + return Qnil; +} + +DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p, + 1, 1, 0, + doc: /* Return t if OBJECT is a condition variable. */) + (Lisp_Object object) +{ + if (CONDVARP (object)) + return Qt; + return Qnil; +} /* Extract and set components of lists. */ @@ -3756,6 +3789,9 @@ syms_of_data (void) DEFSYM (Qchar_table, "char-table"); DEFSYM (Qbool_vector, "bool-vector"); DEFSYM (Qhash_table, "hash-table"); + DEFSYM (Qthread, "thread"); + DEFSYM (Qmutex, "mutex"); + DEFSYM (Qcondition_variable, "condition-variable"); DEFSYM (Qdefun, "defun"); @@ -3796,6 +3832,9 @@ syms_of_data (void) defsubr (&Ssubrp); defsubr (&Sbyte_code_function_p); defsubr (&Schar_or_string_p); + defsubr (&Sthreadp); + defsubr (&Smutexp); + defsubr (&Scondition_variable_p); defsubr (&Scar); defsubr (&Scdr); defsubr (&Scar_safe); diff --git a/src/emacs.c b/src/emacs.c index f633f09098d..bf2f5588d1c 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -155,10 +155,6 @@ bool running_asynch_code; bool display_arg; #endif -/* An address near the bottom of the stack. - Tells GC how to save a copy of the stack. */ -char *stack_bottom; - #if defined GNU_LINUX && !defined CANNOT_DUMP /* The gap between BSS end and heap start as far as we can tell. */ static uprintmax_t heap_bss_diff; @@ -670,7 +666,6 @@ close_output_streams (void) int main (int argc, char **argv) { - Lisp_Object dummy; char stack_bottom_variable; bool do_initial_setlocale; bool dumping; @@ -686,7 +681,8 @@ main (int argc, char **argv) /* If we use --chdir, this records the original directory. */ char *original_pwd = 0; - stack_base = &dummy; + /* Record (approximately) where the stack begins. */ + stack_bottom = &stack_bottom_variable; dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0 || strcmp (argv[argc - 1], "bootstrap") == 0); @@ -878,9 +874,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); @@ -1194,6 +1187,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 (); @@ -1240,6 +1234,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem } init_alloc (); + init_threads (); if (do_initial_setlocale) { @@ -1582,6 +1577,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif /* HAVE_W32NOTIFY */ #endif /* WINDOWSNT */ + syms_of_threads (); syms_of_profiler (); keys_of_casefiddle (); diff --git a/src/eval.c b/src/eval.c index 724f0018a58..c08f93aee0c 100644 --- a/src/eval.c +++ b/src/eval.c @@ -32,7 +32,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ /* 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 @@ -122,6 +124,13 @@ specpdl_where (union specbinding *pdl) } static Lisp_Object +specpdl_saved_value (union specbinding *pdl) +{ + eassert (pdl->kind >= SPECPDL_LET); + return pdl->let.saved_value; +} + +static Lisp_Object specpdl_arg (union specbinding *pdl) { eassert (pdl->kind == SPECPDL_UNWIND); @@ -218,20 +227,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 +1149,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); } @@ -1432,6 +1444,7 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype) 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 +1594,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. */ @@ -3144,6 +3157,44 @@ let_shadows_global_binding_p (Lisp_Object symbol) return 0; } +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_LOCALIZED: + case SYMBOL_FORWARDED: + if ((sym->redirect == SYMBOL_LOCALIZED + || BUFFER_OBJFWDP (SYMBOL_FWD (sym))) + && CONSP (specpdl_symbol (bind))) + { + Lisp_Object where; + + where = XCAR (XCDR (specpdl_symbol (bind))); + if (NILP (where) + && sym->redirect == SYMBOL_FORWARDED) + { + Fset_default (XCAR (specpdl_symbol (bind)), value); + return; + } + } + + 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. @@ -3175,11 +3226,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) @@ -3191,6 +3240,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 ()))); @@ -3211,7 +3261,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; } } @@ -3219,7 +3269,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 (); @@ -3263,7 +3313,84 @@ 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); + + bind->let.saved_value = Qnil; + do_specbind (XSYMBOL (specpdl_symbol (bind)), bind, value); + } + } +} + static void +do_one_unbind (union specbinding *this_binding, int 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. No need to check for constant + symbols here, since that was already done by specbind. */ + struct Lisp_Symbol 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; + } +} + +void do_nothing (void) {} @@ -3322,66 +3449,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, 1); } if (NILP (Vquit_flag) && !NILP (quitf)) @@ -3390,6 +3467,21 @@ 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) + { + bind->let.saved_value = find_symbol_value (specpdl_symbol (bind)); + do_one_unbind (bind, 0); + } + } +} + DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0, doc: /* Return non-nil if SYMBOL's global binding has been declared special. A special variable is one that will be bound dynamically, even in a @@ -3712,10 +3804,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) { @@ -3741,6 +3833,7 @@ mark_specpdl (void) case SPECPDL_LET: mark_object (specpdl_symbol (pdl)); mark_object (specpdl_old_value (pdl)); + mark_object (specpdl_saved_value (pdl)); break; case SPECPDL_UNWIND_PTR: diff --git a/src/lisp.h b/src/lisp.h index 94f1152a56e..d4da32e3ebf 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -34,6 +34,8 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #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: @@ -590,6 +592,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); @@ -758,6 +763,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. */ @@ -804,7 +842,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, PVEC_CHAR_TABLE, @@ -1107,6 +1147,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 @@ -1173,6 +1234,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 @@ -1400,37 +1464,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 @@ -2780,6 +2813,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) @@ -2928,6 +2979,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 @@ -3146,6 +3216,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; @@ -3156,9 +3229,9 @@ union specbinding } bt; }; -extern union specbinding *specpdl; -extern union specbinding *specpdl_ptr; -extern ptrdiff_t specpdl_size; +/* extern union specbinding *specpdl; */ +/* extern union specbinding *specpdl_ptr; */ +/* extern ptrdiff_t specpdl_size; */ INLINE ptrdiff_t SPECPDL_INDEX (void) @@ -3209,18 +3282,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. @@ -3622,9 +3692,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; @@ -3886,7 +3957,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: @@ -3943,6 +4013,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); @@ -3959,7 +4031,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); @@ -3974,6 +4046,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); @@ -4252,6 +4327,8 @@ 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 struct byte_stack *byte_stack_list; extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, ptrdiff_t, Lisp_Object *); extern Lisp_Object get_byte_code_arity (Lisp_Object); diff --git a/src/print.c b/src/print.c index f3db6748d03..6c350fc86aa 100644 --- a/src/print.c +++ b/src/print.c @@ -1911,6 +1911,42 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) } printchar ('>', printcharfun); } + else if (THREADP (obj)) + { + print_c_string ("#<thread ", printcharfun); + if (STRINGP (XTHREAD (obj)->name)) + print_string (XTHREAD (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XTHREAD (obj)); + strout (buf, len, len, printcharfun); + } + printchar ('>', printcharfun); + } + else if (MUTEXP (obj)) + { + print_c_string ("#<mutex ", printcharfun); + if (STRINGP (XMUTEX (obj)->name)) + print_string (XMUTEX (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XMUTEX (obj)); + strout (buf, len, len, printcharfun); + } + printchar ('>', printcharfun); + } + else if (CONDVARP (obj)) + { + print_c_string ("#<condvar ", printcharfun); + if (STRINGP (XCONDVAR (obj)->name)) + print_string (XCONDVAR (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XCONDVAR (obj)); + strout (buf, len, len, printcharfun); + } + printchar ('>', printcharfun); + } else { ptrdiff_t size = ASIZE (obj); diff --git a/src/process.c b/src/process.c index 49340b120ef..e538c86fcf5 100644 --- a/src/process.c +++ b/src/process.c @@ -138,7 +138,7 @@ static struct rlimit nofile_limit; #ifdef WINDOWSNT extern int sys_select (int, fd_set *, fd_set *, fd_set *, - struct timespec *, void *); + struct timespec *, 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,23 @@ add_read_fd (int fd, fd_callback func, void *data) fd_callback_info[fd].func = func; fd_callback_info[fd].data = data; - fd_callback_info[fd].condition |= FOR_READ; +} + +static void +add_non_keyboard_read_fd (int fd) +{ + eassert (fd >= 0 && fd < FD_SETSIZE); + eassert (fd_callback_info[fd].func == NULL); + fd_callback_info[fd].flags |= FOR_READ; + if (fd > max_desc) + max_desc = fd; +} + +static void +add_process_read_fd (int fd) +{ + add_non_keyboard_read_fd (fd); + fd_callback_info[fd].flags |= PROCESS_FD; } /* Stop monitoring file descriptor FD for when read is possible. */ @@ -456,8 +473,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 +486,38 @@ 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; + if (fd > max_desc) + max_desc = fd; fd_callback_info[fd].func = func; fd_callback_info[fd].data = data; - fd_callback_info[fd].condition |= FOR_WRITE; + fd_callback_info[fd].flags |= FOR_WRITE; } -/* 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 +526,123 @@ 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) + int lim = max_desc; + + 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; } } @@ -720,6 +856,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. */ @@ -768,6 +905,27 @@ remove_process (register Lisp_Object proc) deactivate_process (proc); } +void +update_processes_for_thread_death (Lisp_Object dying_thread) +{ + Lisp_Object pair; + + for (pair = Vprocess_alist; !NILP (pair); pair = XCDR (pair)) + { + Lisp_Object process = XCDR (XCAR (pair)); + if (EQ (XPROCESS (process)->thread, dying_thread)) + { + struct Lisp_Process *proc = XPROCESS (process); + + proc->thread = Qnil; + if (proc->infd >= 0) + fd_callback_info[proc->infd].thread = NULL; + if (proc->outfd >= 0) + fd_callback_info[proc->outfd].thread = NULL; + } + } +} + #ifdef HAVE_GETADDRINFO_A static void free_dns_request (Lisp_Object proc) @@ -1070,17 +1228,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_read_fd (p->infd); } DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter, @@ -1167,6 +1319,42 @@ See `set-process-sentinel' for more info on sentinels. */) return XPROCESS (process)->sentinel; } +DEFUN ("set-process-thread", Fset_process_thread, Sset_process_thread, + 2, 2, 0, + doc: /* FIXME */) + (Lisp_Object process, Lisp_Object thread) +{ + struct Lisp_Process *proc; + struct thread_state *tstate; + + CHECK_PROCESS (process); + if (NILP (thread)) + tstate = NULL; + else + { + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + } + + proc = XPROCESS (process); + proc->thread = thread; + if (proc->infd >= 0) + fd_callback_info[proc->infd].thread = tstate; + if (proc->outfd >= 0) + fd_callback_info[proc->outfd].thread = tstate; + + return thread; +} + +DEFUN ("process-thread", Fprocess_thread, Sprocess_thread, + 1, 1, 0, + doc: /* FIXME */) + (Lisp_Object process) +{ + CHECK_PROCESS (process); + return XPROCESS (process)->thread; +} + DEFUN ("set-process-window-size", Fset_process_window_size, Sset_process_window_size, 3, 3, 0, doc: /* Tell PROCESS that it has logical window size WIDTH by HEIGHT. @@ -1843,14 +2031,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) p->pty_flag = pty_flag; 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); @@ -2084,10 +2265,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_non_keyboard_read_fd (pty_fd); pset_tty_name (p, build_string (pty_name)); } @@ -2171,8 +2349,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)) @@ -2193,10 +2371,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_non_keyboard_read_fd (inchannel); p->adaptive_read_buffering = (NILP (Vprocess_adaptive_read_buffering) ? 0 : EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2); @@ -2909,8 +3084,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); @@ -2932,10 +3107,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_non_keyboard_read_fd (fd); if (BUFFERP (buffer)) { @@ -3417,25 +3589,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_non_keyboard_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); @@ -4366,26 +4531,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 (); } } @@ -4414,7 +4564,17 @@ 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 ("FIXME"); + } else just_this_one = Qnil; @@ -4632,13 +4792,7 @@ server_accept_connection (Lisp_Object server, int channel) /* Client processes for accepted connections are not stopped initially. */ if (!EQ (p->filter, Qt)) - { - FD_SET (s, &input_wait_mask); - FD_SET (s, &non_keyboard_wait_mask); - } - - if (s > max_process_desc) - max_process_desc = s; + add_non_keyboard_read_fd (s); /* Setup coding system for new process based on server process. This seems to be the proper thing to do, as the coding system @@ -4751,20 +4905,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; } @@ -4837,6 +4981,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); @@ -5009,14 +5157,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 @@ -5081,17 +5229,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; } @@ -5133,7 +5281,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)) @@ -5192,17 +5340,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 @@ -5386,22 +5535,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; @@ -5466,8 +5615,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) { @@ -5506,14 +5654,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)) @@ -5581,10 +5727,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); - } + delete_read_fd (p->infd); } } } /* End for each file descriptor. */ @@ -6555,10 +6698,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; } @@ -6587,8 +6727,7 @@ traffic. */) && p->infd >= 0 && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten))) { - FD_SET (p->infd, &input_wait_mask); - FD_SET (p->infd, &non_keyboard_wait_mask); + add_non_keyboard_read_fd (p->infd); #ifdef WINDOWSNT if (fd_info[ p->infd ].flags & FILE_SERIAL) PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR); @@ -6895,10 +7034,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); } } } @@ -7258,9 +7394,9 @@ keyboard_bit_set (fd_set *mask) { int fd; - for (fd = 0; fd <= max_input_desc; fd++) - if (FD_ISSET (fd, mask) && FD_ISSET (fd, &input_wait_mask) - && !FD_ISSET (fd, &non_keyboard_wait_mask)) + for (fd = 0; fd <= max_desc; fd++) + if (FD_ISSET (fd, mask) + && ((fd_callback_info[fd].flags & KEYBOARD_FD) != 0)) return 1; return 0; @@ -7497,14 +7633,9 @@ 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); + if (fd > max_desc) + max_desc = fd; } #endif /* HAVE_TIMERFD */ @@ -7528,10 +7659,10 @@ void add_keyboard_wait_descriptor (int desc) { #ifdef subprocesses /* Actually means "not MSDOS". */ - FD_SET (desc, &input_wait_mask); - FD_SET (desc, &non_process_wait_mask); - if (desc > max_input_desc) - max_input_desc = desc; + eassert (desc >= 0 && desc < FD_SETSIZE); + fd_callback_info[desc].flags |= FOR_READ | KEYBOARD_FD; + if (desc > max_desc) + max_desc = desc; #endif } @@ -7541,9 +7672,15 @@ 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); + int fd; + int lim = max_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 } @@ -7824,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; @@ -8032,6 +8164,8 @@ The variable takes effect when `start-process' is called. */); defsubr (&Sprocess_filter); defsubr (&Sset_process_sentinel); defsubr (&Sprocess_sentinel); + defsubr (&Sset_process_thread); + defsubr (&Sprocess_thread); defsubr (&Sset_process_window_size); defsubr (&Sset_process_inherit_coding_system_flag); defsubr (&Sset_process_query_on_exit_flag); diff --git a/src/process.h b/src/process.h index 24c628231a0..e497ebc539f 100644 --- a/src/process.h +++ b/src/process.h @@ -115,6 +115,9 @@ struct Lisp_Process /* Pipe process attached to the standard error of this process. */ Lisp_Object stderrproc; + /* The thread a process is linked to, or nil for any thread. */ + Lisp_Object thread; + /* After this point, there are no Lisp_Objects any more. */ /* alloc.c assumes that `pid' is the first such non-Lisp slot. */ @@ -274,6 +277,8 @@ extern Lisp_Object network_interface_info (Lisp_Object); extern Lisp_Object remove_slash_colon (Lisp_Object); +extern void update_processes_for_thread_death (Lisp_Object); + INLINE_HEADER_END #endif /* EMACS_PROCESS_H */ diff --git a/src/regex.c b/src/regex.c index afd0d180316..bb046858dfe 100644 --- a/src/regex.c +++ b/src/regex.c @@ -1140,13 +1140,13 @@ print_double_string (re_char *where, re_char *string1, ssize_t size1, #endif /* not DEBUG */ #ifndef emacs - /* Set by `re_set_syntax' to the current regexp syntax to recognize. Can also be assigned to arbitrarily: each pattern buffer stores its own syntax, so it can be changed between regex compilations. */ /* This has no initializer because initialized variables in Emacs become read-only after dumping. */ reg_syntax_t re_syntax_options; +#endif /* Specify the precise syntax of regexps for compilation. This provides @@ -1166,7 +1166,20 @@ re_set_syntax (reg_syntax_t syntax) } WEAK_ALIAS (__re_set_syntax, re_set_syntax) +#ifndef emacs +/* Regexp to use to replace spaces, or NULL meaning don't. */ +static const_re_char *whitespace_regexp; +#else +/* whitespace_regexp is a macro defined in thread.h. */ #endif + +void +re_set_whitespace_regexp (const char *regexp) +{ + whitespace_regexp = (const_re_char *) regexp; +} +WEAK_ALIAS (__re_set_syntax, re_set_syntax) +>>>>>>> concurrency /* This table gives an error message for each of the error codes listed in regex.h. Obviously the order here has to be same as there. @@ -4885,12 +4898,6 @@ re_match (struct re_pattern_buffer *bufp, const char *string, WEAK_ALIAS (__re_match, re_match) #endif /* not emacs */ -#ifdef emacs -/* In Emacs, this is the string or buffer in which we are matching. - See the declaration in regex.h for details. */ -Lisp_Object re_match_object; -#endif - /* re_match_2 matches the compiled pattern in BUFP against the the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1 and SIZE2, respectively). We start matching at POS, and stop diff --git a/src/regex.h b/src/regex.h index 4922440e472..2d720e68f22 100644 --- a/src/regex.h +++ b/src/regex.h @@ -171,7 +171,7 @@ typedef unsigned long reg_syntax_t; some interfaces). When a regexp is compiled, the syntax used is stored in the pattern buffer, so changing this does not affect already-compiled regexps. */ -extern reg_syntax_t re_syntax_options; +/* extern reg_syntax_t re_syntax_options; */ #ifdef emacs # include "lisp.h" @@ -180,8 +180,10 @@ extern reg_syntax_t re_syntax_options; If the value is a Lisp string object, we are matching text in that string; if it's nil, we are matching text in the current buffer; if - it's t, we are matching text in a C string. */ -extern Lisp_Object re_match_object; + it's t, we are matching text in a C string. + + This is defined as a macro in thread.h, which see. */ +/* extern Lisp_Object re_match_object; */ #endif /* Roughly the maximum number of failure points on the stack. */ diff --git a/src/search.c b/src/search.c index e597c33a0fb..9d2c8cb04fd 100644 --- a/src/search.c +++ b/src/search.c @@ -40,7 +40,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ struct regexp_cache { struct regexp_cache *next; - Lisp_Object regexp, whitespace_regexp; + Lisp_Object regexp, f_whitespace_regexp; /* Syntax table for which the regexp applies. We need this because of character classes. If this is t, then the compiled pattern is valid for any syntax-table. */ @@ -75,12 +75,12 @@ static struct regexp_cache *searchbuf_head; to call re_set_registers after compiling a new pattern or after setting the match registers, so that the regex functions will be able to free or re-allocate it properly. */ -static struct re_registers search_regs; +/* static struct re_registers search_regs; */ /* The buffer in which the last search was performed, or Qt if the last search was done in a string; Qnil if no searching has been done yet. */ -static Lisp_Object last_thing_searched; +/* static Lisp_Object last_thing_searched; */ static void set_search_regs (ptrdiff_t, ptrdiff_t); static void save_search_regs (void); @@ -122,9 +122,9 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern, cp->buf.multibyte = STRING_MULTIBYTE (pattern); cp->buf.charset_unibyte = charset_unibyte; if (STRINGP (Vsearch_spaces_regexp)) - cp->whitespace_regexp = Vsearch_spaces_regexp; + cp->f_whitespace_regexp = Vsearch_spaces_regexp; else - cp->whitespace_regexp = Qnil; + cp->f_whitespace_regexp = Qnil; /* rms: I think BLOCK_INPUT is not needed here any more, because regex.c defines malloc to call xmalloc. @@ -217,7 +217,7 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp, && cp->posix == posix && (EQ (cp->syntax_table, Qt) || EQ (cp->syntax_table, BVAR (current_buffer, syntax_table))) - && !NILP (Fequal (cp->whitespace_regexp, Vsearch_spaces_regexp)) + && !NILP (Fequal (cp->f_whitespace_regexp, Vsearch_spaces_regexp)) && cp->buf.charset_unibyte == charset_unibyte) break; @@ -3089,9 +3089,9 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */) /* If true the match data have been saved in saved_search_regs during the execution of a sentinel or filter. */ -static bool search_regs_saved; -static struct re_registers saved_search_regs; -static Lisp_Object saved_last_thing_searched; +/* static bool search_regs_saved; */ +/* static struct re_registers saved_search_regs; */ +/* static Lisp_Object saved_last_thing_searched; */ /* Called from Flooking_at, Fstring_match, search_buffer, Fstore_match_data if asynchronous code (filter or sentinel) is running. */ @@ -3401,10 +3401,10 @@ syms_of_search (void) searchbufs[i].buf.buffer = xmalloc (100); searchbufs[i].buf.fastmap = searchbufs[i].fastmap; searchbufs[i].regexp = Qnil; - searchbufs[i].whitespace_regexp = Qnil; + searchbufs[i].f_whitespace_regexp = Qnil; searchbufs[i].syntax_table = Qnil; staticpro (&searchbufs[i].regexp); - staticpro (&searchbufs[i].whitespace_regexp); + staticpro (&searchbufs[i].f_whitespace_regexp); staticpro (&searchbufs[i].syntax_table); searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]); } diff --git a/src/sysdep.c b/src/sysdep.c index 257634292b1..edc3f05ab2b 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -51,13 +51,24 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ # include <math.h> #endif +#ifdef HAVE_SOCKETS +#include <sys/socket.h> +#include <netdb.h> +#endif /* HAVE_SOCKETS */ + +#ifdef TRY_AGAIN +#ifndef HAVE_H_ERRNO +extern int h_errno; +#endif +#endif /* TRY_AGAIN */ + #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> +#include "w32.h" #endif /* not WINDOWSNT */ #include <sys/types.h> diff --git a/src/systhread.c b/src/systhread.c new file mode 100644 index 00000000000..c11e0247886 --- /dev/null +++ b/src/systhread.c @@ -0,0 +1,417 @@ +/* System thread definitions + Copyright (C) 2012, 2013 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#include <config.h> +#include <setjmp.h> +#include "lisp.h" + +#ifndef THREADS_ENABLED + +void +sys_mutex_init (sys_mutex_t *m) +{ + *m = 0; +} + +void +sys_mutex_lock (sys_mutex_t *m) +{ +} + +void +sys_mutex_unlock (sys_mutex_t *m) +{ +} + +void +sys_mutex_destroy (sys_mutex_t *m) +{ +} + +void +sys_cond_init (sys_cond_t *c) +{ + *c = 0; +} + +void +sys_cond_wait (sys_cond_t *c, sys_mutex_t *m) +{ +} + +void +sys_cond_signal (sys_cond_t *c) +{ +} + +void +sys_cond_broadcast (sys_cond_t *c) +{ +} + +void +sys_cond_destroy (sys_cond_t *c) +{ +} + +sys_thread_t +sys_thread_self (void) +{ + return 0; +} + +int +sys_thread_equal (sys_thread_t x, sys_thread_t y) +{ + return x == y; +} + +int +sys_thread_create (sys_thread_t *t, const char *name, + thread_creation_function *func, void *datum) +{ + return 0; +} + +void +sys_thread_yield (void) +{ +} + +#elif defined (HAVE_PTHREAD) + +#include <sched.h> + +#ifdef HAVE_SYS_PRCTL_H +#include <sys/prctl.h> +#endif + +void +sys_mutex_init (sys_mutex_t *mutex) +{ + pthread_mutex_init (mutex, NULL); +} + +void +sys_mutex_lock (sys_mutex_t *mutex) +{ + pthread_mutex_lock (mutex); +} + +void +sys_mutex_unlock (sys_mutex_t *mutex) +{ + pthread_mutex_unlock (mutex); +} + +void +sys_mutex_destroy (sys_mutex_t *mutex) +{ + pthread_mutex_destroy (mutex); +} + +void +sys_cond_init (sys_cond_t *cond) +{ + pthread_cond_init (cond, NULL); +} + +void +sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex) +{ + pthread_cond_wait (cond, mutex); +} + +void +sys_cond_signal (sys_cond_t *cond) +{ + pthread_cond_signal (cond); +} + +void +sys_cond_broadcast (sys_cond_t *cond) +{ + pthread_cond_broadcast (cond); +} + +void +sys_cond_destroy (sys_cond_t *cond) +{ + pthread_cond_destroy (cond); +} + +sys_thread_t +sys_thread_self (void) +{ + return pthread_self (); +} + +int +sys_thread_equal (sys_thread_t one, sys_thread_t two) +{ + return pthread_equal (one, two); +} + +int +sys_thread_create (sys_thread_t *thread_ptr, const char *name, + thread_creation_function *func, void *arg) +{ + pthread_attr_t attr; + int result = 0; + + if (pthread_attr_init (&attr)) + return 0; + + if (!pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED)) + { + result = pthread_create (thread_ptr, &attr, func, arg) == 0; +#if defined (HAVE_SYS_PRCTL_H) && defined (HAVE_PRCTL) && defined (PR_SET_NAME) + if (result && name != NULL) + prctl (PR_SET_NAME, name); +#endif + } + + pthread_attr_destroy (&attr); + + return result; +} + +void +sys_thread_yield (void) +{ + sched_yield (); +} + +#elif defined (WINDOWSNT) + +#include <windows.h> + +/* Cannot include <process.h> because of the local header by the same + name, sigh. */ +uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *); + +/* Mutexes are implemented as critical sections, because they are + faster than Windows mutex objects (implemented in userspace), and + satisfy the requirements, since we only need to synchronize within a + single process. */ +void +sys_mutex_init (sys_mutex_t *mutex) +{ + InitializeCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_mutex_lock (sys_mutex_t *mutex) +{ + /* FIXME: What happens if the owning thread exits without releasing + the mutex? Accoding to MSDN, the result is undefined behavior. */ + EnterCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_mutex_unlock (sys_mutex_t *mutex) +{ + LeaveCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_mutex_destroy (sys_mutex_t *mutex) +{ + /* FIXME: According to MSDN, deleting a critical session that is + owned by a thread leaves the other threads waiting for the + critical session in an undefined state. Posix docs seem to say + the same about pthread_mutex_destroy. Do we need to protect + against such calamities? */ + DeleteCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_cond_init (sys_cond_t *cond) +{ + cond->initialized = false; + cond->wait_count = 0; + /* Auto-reset event for signal. */ + cond->events[CONDV_SIGNAL] = CreateEvent (NULL, FALSE, FALSE, NULL); + /* Manual-reset event for broadcast. */ + cond->events[CONDV_BROADCAST] = CreateEvent (NULL, TRUE, FALSE, NULL); + if (!cond->events[CONDV_SIGNAL] || !cond->events[CONDV_BROADCAST]) + return; + InitializeCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + cond->initialized = true; +} + +void +sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex) +{ + DWORD wait_result; + bool last_thread_waiting; + + if (!cond->initialized) + return; + + /* Increment the wait count avoiding race conditions. */ + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + cond->wait_count++; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + /* Release the mutex and wait for either the signal or the broadcast + event. */ + LeaveCriticalSection ((LPCRITICAL_SECTION)mutex); + wait_result = WaitForMultipleObjects (2, cond->events, FALSE, INFINITE); + + /* Decrement the wait count and see if we are the last thread + waiting on the condition variable. */ + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + cond->wait_count--; + last_thread_waiting = + wait_result == WAIT_OBJECT_0 + CONDV_BROADCAST + && cond->wait_count == 0; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + /* Broadcast uses a manual-reset event, so when the last thread is + released, we must manually reset that event. */ + if (last_thread_waiting) + ResetEvent (cond->events[CONDV_BROADCAST]); + + /* Per the API, re-acquire the mutex. */ + EnterCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_cond_signal (sys_cond_t *cond) +{ + bool threads_waiting; + + if (!cond->initialized) + return; + + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + threads_waiting = cond->wait_count > 0; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + if (threads_waiting) + SetEvent (cond->events[CONDV_SIGNAL]); +} + +void +sys_cond_broadcast (sys_cond_t *cond) +{ + bool threads_waiting; + + if (!cond->initialized) + return; + + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + threads_waiting = cond->wait_count > 0; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + if (threads_waiting) + SetEvent (cond->events[CONDV_BROADCAST]); +} + +void +sys_cond_destroy (sys_cond_t *cond) +{ + if (cond->events[CONDV_SIGNAL]) + CloseHandle (cond->events[CONDV_SIGNAL]); + if (cond->events[CONDV_BROADCAST]) + CloseHandle (cond->events[CONDV_BROADCAST]); + + if (!cond->initialized) + return; + + /* FIXME: What if wait_count is non-zero, i.e. there are still + threads waiting on this condition variable? */ + DeleteCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); +} + +sys_thread_t +sys_thread_self (void) +{ + return (sys_thread_t) GetCurrentThreadId (); +} + +int +sys_thread_equal (sys_thread_t one, sys_thread_t two) +{ + return one == two; +} + +static thread_creation_function *thread_start_address; + +/* _beginthread wants a void function, while we are passed a function + that returns a pointer. So we use a wrapper. */ +static void +w32_beginthread_wrapper (void *arg) +{ + (void)thread_start_address (arg); +} + +int +sys_thread_create (sys_thread_t *thread_ptr, const char *name, + thread_creation_function *func, void *arg) +{ + /* FIXME: Do threads that run Lisp require some minimum amount of + stack? Zero here means each thread will get the same amount as + the main program. On GNU/Linux, it seems like the stack is 2MB + by default, overridden by RLIMIT_STACK at program start time. + Not sure what to do with this. See also the comment in + w32proc.c:new_child. */ + const unsigned stack_size = 0; + uintptr_t thandle; + + thread_start_address = func; + + /* We use _beginthread rather than CreateThread because the former + arranges for the thread handle to be automatically closed when + the thread exits, thus preventing handle leaks and/or the need to + track all the threads and close their handles when they exit. + Also, MSDN seems to imply that code which uses CRT _must_ call + _beginthread, although if that is true, we already violate that + rule in many places... */ + thandle = _beginthread (w32_beginthread_wrapper, stack_size, arg); + if (thandle == (uintptr_t)-1L) + return 0; + + /* Kludge alert! We use the Windows thread ID, an unsigned 32-bit + number, as the sys_thread_t type, because that ID is the only + unique identifier of a thread on Windows. But _beginthread + returns a handle of the thread, and there's no easy way of + getting the thread ID given a handle (GetThreadId is available + only since Vista, so we cannot use it portably). Fortunately, + the value returned by sys_thread_create is not used by its + callers; instead, run_thread, which runs in the context of the + new thread, calls sys_thread_self and uses its return value; + sys_thread_self in this implementation calls GetCurrentThreadId. + Therefore, we return some more or less arbitrary value of the + thread ID from this function. */ + *thread_ptr = thandle & 0xFFFFFFFF; + return 1; +} + +void +sys_thread_yield (void) +{ + Sleep (0); +} + +#else + +#error port me + +#endif diff --git a/src/systhread.h b/src/systhread.h new file mode 100644 index 00000000000..b38fd8ffd45 --- /dev/null +++ b/src/systhread.h @@ -0,0 +1,112 @@ +/* System thread definitions + Copyright (C) 2012, 2013 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#ifndef SYSTHREAD_H +#define SYSTHREAD_H + +#ifdef THREADS_ENABLED + +#ifdef HAVE_PTHREAD + +#include <pthread.h> + +/* A system mutex is just a pthread mutex. This is only used for the + GIL. */ +typedef pthread_mutex_t sys_mutex_t; + +typedef pthread_cond_t sys_cond_t; + +/* A system thread. */ +typedef pthread_t sys_thread_t; + +#else /* HAVE_PTHREAD */ + +#ifdef WINDOWSNT + +/* This header is indirectly included in every source file. We don't + want to include windows.h in every source file, so we repeat + declarations of the few necessary data types here (under different + names, to avoid conflicts with files that do include + windows.h). */ + +typedef struct { + struct _CRITICAL_SECTION_DEBUG *DebugInfo; + long LockCount; + long RecursionCount; + void *OwningThread; + void *LockSemaphore; + unsigned long SpinCount; +} w32thread_critsect; + +enum { CONDV_SIGNAL = 0, CONDV_BROADCAST = 1, CONDV_MAX = 2 }; + +typedef struct { + /* Count of threads that are waiting for this condition variable. */ + unsigned wait_count; + /* Critical section to protect changes to the count above. */ + w32thread_critsect wait_count_lock; + /* Handles of events used for signal and broadcast. */ + void *events[CONDV_MAX]; + bool initialized; +} w32thread_cond_t; + +typedef w32thread_critsect sys_mutex_t; + +typedef w32thread_cond_t sys_cond_t; + +typedef unsigned long sys_thread_t; + +#else /* !WINDOWSNT */ + +#error port me + +#endif /* WINDOWSNT */ +#endif /* HAVE_PTHREAD */ + +#else /* THREADS_ENABLED */ + +/* For the no-threads case we can simply use dummy definitions. */ +typedef int sys_mutex_t; +typedef int sys_cond_t; +typedef int sys_thread_t; + +#endif /* THREADS_ENABLED */ + +typedef void *(thread_creation_function) (void *); + +extern void sys_mutex_init (sys_mutex_t *); +extern void sys_mutex_lock (sys_mutex_t *); +extern void sys_mutex_unlock (sys_mutex_t *); +extern void sys_mutex_destroy (sys_mutex_t *); + +extern void sys_cond_init (sys_cond_t *); +extern void sys_cond_wait (sys_cond_t *, sys_mutex_t *); +extern void sys_cond_signal (sys_cond_t *); +extern void sys_cond_broadcast (sys_cond_t *); +extern void sys_cond_destroy (sys_cond_t *); + +extern sys_thread_t sys_thread_self (void); +extern int sys_thread_equal (sys_thread_t, sys_thread_t); + +extern int sys_thread_create (sys_thread_t *, const char *, + thread_creation_function *, + void *); + +extern void sys_thread_yield (void); + +#endif /* SYSTHREAD_H */ diff --git a/src/thread.c b/src/thread.c new file mode 100644 index 00000000000..f5b04e4b231 --- /dev/null +++ b/src/thread.c @@ -0,0 +1,975 @@ +/* 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) +{ + struct thread_state *self = current_thread; + + if (mutex->owner != current_thread) + error ("blah"); + + if (--mutex->count > 0) + return 0; + + mutex->owner = NULL; + sys_cond_broadcast (&mutex->condition); + + return 1; +} + +static unsigned int +lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex) +{ + struct thread_state *self = current_thread; + unsigned int result = mutex->count; + + /* Ensured by condvar code. */ + eassert (mutex->owner == current_thread); + + mutex->count = 0; + mutex->owner = NULL; + sys_cond_broadcast (&mutex->condition); + + return result; +} + +static void +lisp_mutex_destroy (lisp_mutex_t *mutex) +{ + sys_cond_destroy (&mutex->condition); +} + +static int +lisp_mutex_owned_p (lisp_mutex_t *mutex) +{ + return mutex->owner == current_thread; +} + + + +DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0, + doc: /* Create a mutex. +A mutex provides a synchronization point for threads. +Only one thread at a time can hold a mutex. Other threads attempting +to acquire it will block until the mutex is available. + +A thread can acquire a mutex any number of times. + +NAME, if given, is used as the name of the mutex. The name is +informational only. */) + (Lisp_Object name) +{ + struct Lisp_Mutex *mutex; + Lisp_Object result; + + if (!NILP (name)) + CHECK_STRING (name); + + mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX); + memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex), + 0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex, + mutex)); + mutex->name = name; + lisp_mutex_init (&mutex->mutex); + + XSETMUTEX (result, mutex); + return result; +} + +static void +mutex_lock_callback (void *arg) +{ + struct Lisp_Mutex *mutex = arg; + struct thread_state *self = current_thread; + + if (lisp_mutex_lock (&mutex->mutex, 0)) + post_acquire_global_lock (self); +} + +static 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. +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 to be notified. +CONDITION is the condition variable to wait on. + +The mutex associated with CONDITION must be held when this is called. +It is an error if it is not held. + +This releases the mutex and waits for CONDITION to be notified or for +this thread to be signalled with `thread-signal'. When +`condition-wait' returns, the mutex will again be locked by this +thread. */) + (Lisp_Object condition) +{ + struct Lisp_CondVar *cvar; + struct Lisp_Mutex *mutex; + + CHECK_CONDVAR (condition); + cvar = XCONDVAR (condition); + + mutex = XMUTEX (cvar->mutex); + if (!lisp_mutex_owned_p (&mutex->mutex)) + error ("fixme"); + + flush_stack_call_func (condition_wait_callback, cvar); + + return Qnil; +} + +/* Used to communicate argumnets to condition_notify_callback. */ +struct notify_args +{ + struct Lisp_CondVar *cvar; + int all; +}; + +static void +condition_notify_callback (void *arg) +{ + struct notify_args *na = arg; + struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex); + struct thread_state *self = current_thread; + unsigned int saved_count; + Lisp_Object cond; + + XSETCONDVAR (cond, na->cvar); + saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex); + if (na->all) + sys_cond_broadcast (&na->cvar->cond); + else + sys_cond_signal (&na->cvar->cond); + lisp_mutex_lock (&mutex->mutex, saved_count); + post_acquire_global_lock (self); +} + +DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0, + doc: /* Notify a condition variable. +This wakes a thread waiting on CONDITION. +If ALL is non-nil, all waiting threads are awoken. + +The mutex associated with CONDITION must be held when this is called. +It is an error if it is not held. + +This releases the mutex when notifying CONDITION. When +`condition-notify' returns, the mutex will again be locked by this +thread. */) + (Lisp_Object condition, Lisp_Object all) +{ + struct Lisp_CondVar *cvar; + struct Lisp_Mutex *mutex; + struct notify_args args; + + CHECK_CONDVAR (condition); + cvar = XCONDVAR (condition); + + mutex = XMUTEX (cvar->mutex); + if (!lisp_mutex_owned_p (&mutex->mutex)) + error ("fixme"); + + args.cvar = cvar; + args.all = !NILP (all); + flush_stack_call_func (condition_notify_callback, &args); + + return Qnil; +} + +DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0, + doc: /* Return the mutex associated with CONDITION. */) + (Lisp_Object condition) +{ + struct Lisp_CondVar *cvar; + + CHECK_CONDVAR (condition); + cvar = XCONDVAR (condition); + + return cvar->mutex; +} + +DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0, + doc: /* Return the name of CONDITION. +If no name was given when CONDITION was created, return nil. */) + (Lisp_Object condition) +{ + struct Lisp_CondVar *cvar; + + CHECK_CONDVAR (condition); + cvar = XCONDVAR (condition); + + return cvar->name; +} + +void +finalize_one_condvar (struct Lisp_CondVar *condvar) +{ + sys_cond_destroy (&condvar->cond); +} + + + +struct select_args +{ + select_func *func; + int max_fds; + 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 (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) +{ + Lisp_Object iter; + volatile struct thread_state *self = current_thread; + + int count = SPECPDL_INDEX (); + + Ffuncall (1, ¤t_thread->function); + return unbind_to (count, Qnil); +} + +static Lisp_Object +do_nothing (Lisp_Object whatever) +{ + return whatever; +} + +static void * +run_thread (void *state) +{ + char stack_pos; + struct thread_state *self = state; + struct thread_state **iter; + + self->m_stack_bottom = &stack_pos; + self->stack_top = &stack_pos; + self->thread_id = sys_thread_self (); + + acquire_global_lock (self); + + { /* Put a dummy catcher at top-level so that handlerlist is never NULL. + This is important since handlerlist->nextfree holds the freelist + which would otherwise leak every time we unwind back to top-level. */ + handlerlist_sentinel = xzalloc (sizeof (struct handler)); + handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel; + struct handler *c = push_handler (Qunbound, CATCHER); + eassert (c == handlerlist_sentinel); + handlerlist_sentinel->nextfree = NULL; + handlerlist_sentinel->next = NULL; + } + + /* It might be nice to do something with errors here. */ + internal_condition_case (invoke_thread_function, Qt, do_nothing); + + update_processes_for_thread_death (Fcurrent_thread ()); + + xfree (self->m_specpdl - 1); + self->m_specpdl = NULL; + self->m_specpdl_ptr = NULL; + self->m_specpdl_size = 0; + + { + struct handler *c, *c_next; + for (c = handlerlist_sentinel; c; c = c_next) + { + c_next = c->nextfree; + xfree (c); + } + } + + current_thread = NULL; + sys_cond_broadcast (&self->thread_condvar); + + /* Unlink this thread from the list of all threads. Note that we + have to do this very late, after broadcasting our death. + Otherwise the GC may decide to reap the thread_state object, + leading to crashes. */ + for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread) + ; + *iter = (*iter)->next_thread; + + release_global_lock (); + + return NULL; +} + +void +finalize_one_thread (struct thread_state *state) +{ + sys_cond_destroy (&state->thread_condvar); +} + +DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0, + doc: /* Start a new thread and run FUNCTION in it. +When the function exits, the thread dies. +If NAME is given, it 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) + 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 a thread to exit. +This blocks the current thread until THREAD exits. +It is an error for a thread to try to join itself. */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + if (tstate == current_thread) + error ("cannot join current thread"); + + if (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 threads. */) + (void) +{ + Lisp_Object result = Qnil; + struct thread_state *iter; + + for (iter = all_threads; iter; iter = iter->next_thread) + { + if (thread_alive_p (iter)) + { + Lisp_Object thread; + + XSETTHREAD (thread, iter); + result = Fcons (thread, result); + } + } + + return result; +} + + + +bool +thread_check_current_buffer (struct buffer *buffer) +{ + struct thread_state *iter; + + for (iter = all_threads; iter; iter = iter->next_thread) + { + if (iter == current_thread) + continue; + + if (iter->m_current_buffer == buffer) + return true; + } + + return false; +} + + + +static void +init_primary_thread (void) +{ + primary_thread.header.size + = PSEUDOVECSIZE (struct thread_state, m_byte_stack_list); + XSETPVECTYPE (&primary_thread, PVEC_THREAD); + primary_thread.m_last_thing_searched = Qnil; + primary_thread.m_saved_last_thing_searched = Qnil; + primary_thread.name = Qnil; + primary_thread.function = Qnil; + primary_thread.error_symbol = Qnil; + primary_thread.error_data = Qnil; + primary_thread.event_object = Qnil; +} + +void +init_threads_once (void) +{ + init_primary_thread (); +} + +void +init_threads (void) +{ + init_primary_thread (); + sys_cond_init (&primary_thread.thread_condvar); + sys_mutex_init (&global_lock); + sys_mutex_lock (&global_lock); + current_thread = &primary_thread; + primary_thread.thread_id = sys_thread_self (); +} + +void +syms_of_threads (void) +{ +#ifndef THREADS_ENABLED + if (0) +#endif + { + defsubr (&Sthread_yield); + defsubr (&Smake_thread); + defsubr (&Scurrent_thread); + defsubr (&Sthread_name); + defsubr (&Sthread_signal); + defsubr (&Sthread_alive_p); + defsubr (&Sthread_join); + defsubr (&Sthread_blocker); + defsubr (&Sall_threads); + defsubr (&Smake_mutex); + defsubr (&Smutex_lock); + defsubr (&Smutex_unlock); + defsubr (&Smutex_name); + defsubr (&Smake_condition_variable); + defsubr (&Scondition_wait); + defsubr (&Scondition_notify); + defsubr (&Scondition_mutex); + defsubr (&Scondition_name); + } + + DEFSYM (Qthreadp, "threadp"); + DEFSYM (Qmutexp, "mutexp"); + DEFSYM (Qcondition_variable_p, "condition-variable-p"); +} diff --git a/src/thread.h b/src/thread.h new file mode 100644 index 00000000000..a089c7de573 --- /dev/null +++ b/src/thread.h @@ -0,0 +1,248 @@ +/* Thread definitions + Copyright (C) 2012, 2013 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#ifndef THREAD_H +#define THREAD_H + +#include "regex.h" + +#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) + + /* Set by `re_set_syntax' to the current regexp syntax to recognize. Can + also be assigned to arbitrarily: each pattern buffer stores its own + syntax, so it can be changed between regex compilations. */ + reg_syntax_t m_re_syntax_options; +#define re_syntax_options (current_thread->m_re_syntax_options) + + /* Regexp to use to replace spaces, or NULL meaning don't. */ + /* This ought to be a "const re_char *" but that is not available + outside regex.h. */ + const void *m_whitespace_regexp; +#define whitespace_regexp (current_thread->m_whitespace_regexp) + + /* This variable is different from waiting_for_input in keyboard.c. + It is used to communicate to a lisp process-filter/sentinel (via the + function Fwaiting_for_user_input_p) whether Emacs was waiting + for user-input when that process-filter was called. + waiting_for_input cannot be used as that is by definition 0 when + lisp code is being evalled. + This is also used in record_asynch_buffer_change. + For that purpose, this must be 0 + when not inside wait_reading_process_output. */ + int m_waiting_for_user_input_p; +#define waiting_for_user_input_p (current_thread->m_waiting_for_user_input_p) + + /* The OS identifier for this thread. */ + sys_thread_t thread_id; + + /* The condition variable for this thread. This is associated with + the global lock. This thread broadcasts to it when it exits. */ + sys_cond_t thread_condvar; + + /* This thread might be waiting for some condition. If so, this + points to the condition. If the thread is interrupted, the + interrupter should broadcast to this condition. */ + sys_cond_t *wait_condvar; + + /* Threads are kept on a linked list. */ + struct thread_state *next_thread; +}; + +/* A mutex in lisp is represented by a system condition variable. + The system mutex associated with this condition variable is the + global lock. + + Using a condition variable lets us implement interruptibility for + lisp mutexes. */ +typedef struct +{ + /* The owning thread, or NULL if unlocked. */ + struct thread_state *owner; + /* The lock count. */ + unsigned int count; + /* The underlying system condition variable. */ + sys_cond_t condition; +} lisp_mutex_t; + +/* A mutex as a lisp object. */ +struct Lisp_Mutex +{ + struct vectorlike_header header; + + /* The name of the mutex, or nil. */ + Lisp_Object name; + + /* The lower-level mutex object. */ + lisp_mutex_t mutex; +}; + +/* A condition variable as a lisp object. */ +struct Lisp_CondVar +{ + struct vectorlike_header header; + + /* The associated mutex. */ + Lisp_Object mutex; + + /* The name of the condition variable, or nil. */ + Lisp_Object name; + + /* The lower-level condition variable object. */ + sys_cond_t cond; +}; + +extern struct thread_state *current_thread; + +extern void unmark_threads (void); +extern void finalize_one_thread (struct thread_state *state); +extern void finalize_one_mutex (struct Lisp_Mutex *); +extern void finalize_one_condvar (struct Lisp_CondVar *); + +extern void init_threads_once (void); +extern void init_threads (void); +extern void syms_of_threads (void); + +typedef int select_func (int, fd_set *, fd_set *, fd_set *, + struct timespec *, sigset_t *); + +int thread_select (select_func *func, int max_fds, fd_set *rfds, + fd_set *wfds, fd_set *efds, struct timespec *timeout, + sigset_t *sigmask); + +bool thread_check_current_buffer (struct buffer *); + +#endif /* THREAD_H */ diff --git a/src/w32.c b/src/w32.c index 086c1acfb38..7a80275a7c8 100644 --- a/src/w32.c +++ b/src/w32.c @@ -272,7 +272,7 @@ static BOOL WINAPI revert_to_self (void); static int sys_access (const char *, int); extern void *e_malloc (size_t); extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, - struct timespec *, void *); + struct timespec *, sigset_t *); extern int sys_dup (int); diff --git a/src/w32.h b/src/w32.h index 702bb5255cd..760bb14c00d 100644 --- a/src/w32.h +++ b/src/w32.h @@ -25,7 +25,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <windows.h> - /* File descriptor set emulation. */ /* MSVC runtime library has limit of 64 descriptors by default */ diff --git a/src/w32proc.c b/src/w32proc.c index 189034c4e2d..2d2d948bfea 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -2096,7 +2096,7 @@ extern int proc_buffered_char[]; int sys_select (int nfds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, - struct timespec *timeout, void *ignored) + struct timespec *timeout, sigset_t *ignored) { SELECT_TYPE orfds, owfds; DWORD timeout_ms, start_time; diff --git a/src/window.c b/src/window.c index acbefcdad16..9460057262c 100644 --- a/src/window.c +++ b/src/window.c @@ -6008,7 +6008,7 @@ struct save_window_data struct vectorlike_header header; Lisp_Object selected_frame; Lisp_Object current_window; - Lisp_Object current_buffer; + Lisp_Object f_current_buffer; Lisp_Object minibuf_scroll_window; Lisp_Object minibuf_selected_window; Lisp_Object root_window; @@ -6098,7 +6098,7 @@ the return value is nil. Otherwise the value is t. */) data = (struct save_window_data *) XVECTOR (configuration); saved_windows = XVECTOR (data->saved_windows); - new_current_buffer = data->current_buffer; + new_current_buffer = data->f_current_buffer; if (!BUFFER_LIVE_P (XBUFFER (new_current_buffer))) new_current_buffer = Qnil; else @@ -6750,7 +6750,7 @@ saved by this function. */) data->frame_tool_bar_height = FRAME_TOOL_BAR_HEIGHT (f); data->selected_frame = selected_frame; data->current_window = FRAME_SELECTED_WINDOW (f); - XSETBUFFER (data->current_buffer, current_buffer); + XSETBUFFER (data->f_current_buffer, current_buffer); data->minibuf_scroll_window = minibuf_level > 0 ? Vminibuf_scroll_window : Qnil; data->minibuf_selected_window = minibuf_level > 0 ? minibuf_selected_window : Qnil; data->root_window = FRAME_ROOT_WINDOW (f); @@ -7205,7 +7205,7 @@ compare_window_configurations (Lisp_Object configuration1, || d1->frame_lines != d2->frame_lines || d1->frame_menu_bar_lines != d2->frame_menu_bar_lines || !EQ (d1->selected_frame, d2->selected_frame) - || !EQ (d1->current_buffer, d2->current_buffer) + || !EQ (d1->f_current_buffer, d2->f_current_buffer) || (!ignore_positions && (!EQ (d1->minibuf_scroll_window, d2->minibuf_scroll_window) || !EQ (d1->minibuf_selected_window, d2->minibuf_selected_window))) diff --git a/src/xgselect.c b/src/xgselect.c index 7850a16e9c0..e418e1a3c4e 100644 --- a/src/xgselect.c +++ b/src/xgselect.c @@ -54,9 +54,8 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, 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,8 @@ 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); + 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 +98,8 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, } } - SAFE_FREE (); + if (must_free) + xfree (gfds); if (n_gfds >= 0 && tmo_in_millisec >= 0) { diff --git a/test/automated/bindings.el b/test/automated/bindings.el new file mode 100644 index 00000000000..4b88baeef40 --- /dev/null +++ b/test/automated/bindings.el @@ -0,0 +1,99 @@ +;;; bindings.el --- tests for variable bindings + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Code: + +(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 + +;;; bindings.el ends here diff --git a/test/automated/threads.el b/test/automated/threads.el new file mode 100644 index 00000000000..c65b6425c3c --- /dev/null +++ b/test/automated/threads.el @@ -0,0 +1,213 @@ +;;; threads.el --- tests for threads. + +;; Copyright (C) 2012, 2013 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Code: + +(ert-deftest threads-is-one () + "test for existence of a thread" + (should (current-thread))) + +(ert-deftest threads-threadp () + "test of threadp" + (should (threadp (current-thread)))) + +(ert-deftest threads-type () + "test of thread type" + (should (eq (type-of (current-thread)) 'thread))) + +(ert-deftest threads-name () + "test for name of a thread" + (should + (string= "hi bob" (thread-name (make-thread #'ignore "hi bob"))))) + +(ert-deftest threads-alive () + "test for thread liveness" + (should + (thread-alive-p (make-thread #'ignore)))) + +(ert-deftest threads-all-threads () + "simple test for all-threads" + (should (listp (all-threads)))) + +(defvar threads-test-global nil) + +(defun threads-test-thread1 () + (setq threads-test-global 23)) + +(ert-deftest threads-basic () + "basic thread test" + (should + (progn + (setq threads-test-global nil) + (make-thread #'threads-test-thread1) + (while (not threads-test-global) + (thread-yield)) + threads-test-global))) + +(ert-deftest threads-join () + "test of thread-join" + (should + (progn + (setq threads-test-global nil) + (let ((thread (make-thread #'threads-test-thread1))) + (thread-join thread) + (and threads-test-global + (not (thread-alive-p thread))))))) + +(ert-deftest threads-join-self () + "cannot thread-join the current thread" + (should-error (thread-join (current-thread)))) + +(defvar threads-test-binding nil) + +(defun threads-test-thread2 () + (let ((threads-test-binding 23)) + (thread-yield)) + (setq threads-test-global 23)) + +(ert-deftest threads-let-binding () + "simple test of threads and let bindings" + (should + (progn + (setq threads-test-global nil) + (make-thread #'threads-test-thread2) + (while (not threads-test-global) + (thread-yield)) + (and (not threads-test-binding) + threads-test-global)))) + +(ert-deftest threads-mutexp () + "simple test of mutexp" + (should-not (mutexp 'hi))) + +(ert-deftest threads-mutexp-2 () + "another simple test of mutexp" + (should (mutexp (make-mutex)))) + +(ert-deftest threads-mutex-type () + "type-of mutex" + (should (eq (type-of (make-mutex)) 'mutex))) + +(ert-deftest threads-mutex-lock-unlock () + "test mutex-lock and unlock" + (should + (let ((mx (make-mutex))) + (mutex-lock mx) + (mutex-unlock mx) + t))) + +(ert-deftest threads-mutex-recursive () + "test mutex-lock and unlock" + (should + (let ((mx (make-mutex))) + (mutex-lock mx) + (mutex-lock mx) + (mutex-unlock mx) + (mutex-unlock mx) + t))) + +(defvar threads-mutex nil) +(defvar threads-mutex-key nil) + +(defun threads-test-mlock () + (mutex-lock threads-mutex) + (setq threads-mutex-key 23) + (while threads-mutex-key + (thread-yield)) + (mutex-unlock threads-mutex)) + +(ert-deftest threads-mutex-contention () + "test of mutex contention" + (should + (progn + (setq threads-mutex (make-mutex)) + (setq threads-mutex-key nil) + (make-thread #'threads-test-mlock) + ;; Wait for other thread to get the lock. + (while (not threads-mutex-key) + (thread-yield)) + ;; Try now. + (setq threads-mutex-key nil) + (mutex-lock threads-mutex) + (mutex-unlock threads-mutex) + t))) + +(defun threads-test-mlock2 () + (setq threads-mutex-key 23) + (mutex-lock threads-mutex)) + +(ert-deftest threads-mutex-signal () + "test signalling a blocked thread" + (should + (progn + (setq threads-mutex (make-mutex)) + (setq threads-mutex-key nil) + (mutex-lock threads-mutex) + (let ((thr (make-thread #'threads-test-mlock2))) + (while (not threads-mutex-key) + (thread-yield)) + (thread-signal thr 'quit nil) + (thread-join thr)) + t))) + +(defun threads-test-io-switch () + (setq threads-test-global 23)) + +(ert-deftest threads-io-switch () + "test that accept-process-output causes thread switch" + (should + (progn + (setq threads-test-global nil) + (make-thread #'threads-test-io-switch) + (while (not threads-test-global) + (accept-process-output nil 1)) + threads-test-global))) + +(ert-deftest threads-condvarp () + "simple test of condition-variable-p" + (should-not (condition-variable-p 'hi))) + +(ert-deftest threads-condvarp-2 () + "another simple test of condition-variable-p" + (should (condition-variable-p (make-condition-variable (make-mutex))))) + +(ert-deftest threads-condvar-type () + "type-of condvar" + (should (eq (type-of (make-condition-variable (make-mutex))) + 'condition-variable))) + +(ert-deftest threads-condvar-mutex () + "simple test of condition-mutex" + (should + (let ((m (make-mutex))) + (eq m (condition-mutex (make-condition-variable m)))))) + +(ert-deftest threads-condvar-name () + "simple test of condition-name" + (should + (eq nil (condition-name (make-condition-variable (make-mutex)))))) + +(ert-deftest threads-condvar-name-2 () + "another simple test of condition-name" + (should + (string= "hi bob" + (condition-name (make-condition-variable (make-mutex) + "hi bob"))))) + +;;; threads.el ends here |