diff options
| -rw-r--r-- | configure.ac | 4 | ||||
| -rw-r--r-- | doc/lispref/Makefile.in | 1 | ||||
| -rw-r--r-- | doc/lispref/elisp.texi | 8 | ||||
| -rw-r--r-- | doc/lispref/objects.texi | 20 | ||||
| -rw-r--r-- | doc/lispref/processes.texi | 30 | ||||
| -rw-r--r-- | doc/lispref/threads.texi | 258 | ||||
| -rw-r--r-- | lisp/subr.el | 28 | ||||
| -rw-r--r-- | src/Makefile.in | 1 | ||||
| -rw-r--r-- | src/alloc.c | 90 | ||||
| -rw-r--r-- | src/buffer.c | 5 | ||||
| -rw-r--r-- | src/buffer.h | 4 | ||||
| -rw-r--r-- | src/bytecode.c | 13 | ||||
| -rw-r--r-- | src/data.c | 43 | ||||
| -rw-r--r-- | src/emacs.c | 18 | ||||
| -rw-r--r-- | src/eval.c | 273 | ||||
| -rw-r--r-- | src/lisp.h | 181 | ||||
| -rw-r--r-- | src/print.c | 36 | ||||
| -rw-r--r-- | src/process.c | 523 | ||||
| -rw-r--r-- | src/process.h | 5 | ||||
| -rw-r--r-- | src/regex.c | 10 | ||||
| -rw-r--r-- | src/regex.h | 4 | ||||
| -rw-r--r-- | src/search.c | 22 | ||||
| -rw-r--r-- | src/systhread.c | 131 | ||||
| -rw-r--r-- | src/systhread.h | 63 | ||||
| -rw-r--r-- | src/systime.h | 4 | ||||
| -rw-r--r-- | src/thread.c | 965 | ||||
| -rw-r--r-- | src/thread.h | 244 | ||||
| -rw-r--r-- | src/window.c | 8 | ||||
| -rw-r--r-- | src/xgselect.c | 9 | ||||
| -rw-r--r-- | test/automated/bindings.el | 99 | ||||
| -rw-r--r-- | test/automated/threads.el | 213 |
31 files changed, 2874 insertions, 439 deletions
diff --git a/configure.ac b/configure.ac index 0fdb1699e99..73dcdb06bee 100644 --- a/configure.ac +++ b/configure.ac @@ -1315,7 +1315,7 @@ AC_CHECK_HEADERS_ONCE( sys/systeminfo.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_MSG_CHECKING(if personality LINUX32 can be set) AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/personality.h>]], [[personality (PER_LINUX32)]])], @@ -3255,7 +3255,7 @@ gai_strerror mkostemp mkstemp getline getdelim sync \ difftime posix_memalign \ getpwent endpwent getgrent endgrent \ touchlock \ -cfmakeraw cfsetspeed copysign __executable_start log2) +cfmakeraw cfsetspeed copysign __executable_start log2 prctl) ## Eric Backus <ericb@lsid.hp.com> says, HP-UX 9.x on HP 700 machines ## has a broken `rint' in some library versions including math library diff --git a/doc/lispref/Makefile.in b/doc/lispref/Makefile.in index 19cf2cc4a5d..c548b67d4ca 100644 --- a/doc/lispref/Makefile.in +++ b/doc/lispref/Makefile.in @@ -97,6 +97,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 59bbdec0229..0d9432d5e01 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -221,6 +221,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 @@ -1290,6 +1291,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. @@ -1590,6 +1597,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 3b7dc41335b..61007cc5a12 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -1897,6 +1897,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 @@ -1910,11 +1919,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{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{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 1181244a974..e869bb86e40 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -1174,6 +1174,7 @@ shell command. * 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 @@ -1504,6 +1505,35 @@ did get some output, or @code{nil} if the timeout expired before output 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..9c333546040 --- /dev/null +++ b/doc/lispref/threads.texi @@ -0,0 +1,258 @@ +@c -*-texinfo-*- +@c This is part of the GNU Emacs Lisp Reference Manual. +@c Copyright (C) 2012 +@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. + +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. Emacs Lisp provides a macro, +@code{until-condition}, to do this automatically. + + 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 signal it: + +@example +(with-mutex mutex + (setq global-variable (some-computation)) + (condition-signal 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 + +@defmac until-condition test cond +Acquire the mutex associated with @var{cond}, and then loop, invoking +the form @var{test}. If @var{test} evaluates to @code{nil}, invoke +@code{condition-wait} on @var{cond}. +@end defmac diff --git a/lisp/subr.el b/lisp/subr.el index b6ee96f879e..a2afe0768c4 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4726,6 +4726,34 @@ as alpha versions." (version-list-= (version-to-list v1) (version-to-list v2))) +;;; 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))))) + +(defmacro until-condition (test condition) + "Wait for the condition variable CONDITION, checking TEST. +Acquire CONDITION's mutex, then check TEST. +If TEST evaluates to nil, repeatedly invoke `condition-wait' on CONDITION. +When CONDITION is signalled, check TEST again. + +This is the simplest safe way to invoke `condition-wait'." + (let ((cond-sym (make-symbol "condition"))) + `(let ((,cond-sym ,condition)) + (with-mutex (condition-mutex ,cond-sym) + (while (not ,test) + (condition-wait ,cond-sym)))))) + + + ;;; Misc. (defconst menu-bar-separator '("--") "Separator for menus.") diff --git a/src/Makefile.in b/src/Makefile.in index 931b3e71d66..2bd1fc43239 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -375,6 +375,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ region-cache.o sound.o atimer.o \ doprnt.o intervals.o textprop.o composite.o xml.o $(NOTIFY_OBJ) \ profiler.o \ + thread.o systhread.o \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) obj = $(base_obj) $(NS_OBJC_OBJ) diff --git a/src/alloc.c b/src/alloc.c index b71cdb98d78..6ef6af1e3a1 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -302,10 +302,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; @@ -335,10 +331,6 @@ static struct mem_node *mem_find (void *); # define DEADP(x) 0 #endif -/* Recording what needs to be marked for gc. */ - -struct gcpro *gcprolist; - /* Addresses of staticpro'd variables. Initialize it to a nonzero value; otherwise some compilers put it into BSS. */ @@ -2837,6 +2829,13 @@ sweep_vectors (void) { ptrdiff_t total_bytes; + 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); + nbytes = vector_nbytes (vector); total_bytes = nbytes; next = ADVANCE (vector, nbytes); @@ -4651,10 +4650,30 @@ dump_zombies (void) would be necessary, each one starting with one byte more offset from the stack start. */ -static void -mark_stack (void) +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 (bottom, end); + + /* Allow for marking a secondary stack, like the register stack on the + ia64. */ +#ifdef GC_MARK_SECONDARY_STACK + GC_MARK_SECONDARY_STACK (); +#endif + +#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS + check_gcpros (); +#endif +} + +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. @@ -4669,7 +4688,7 @@ mark_stack (void) Lisp_Object o; sys_jmp_buf j; } j; - volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base; + 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. */ @@ -4708,20 +4727,10 @@ mark_stack (void) #endif /* not GC_SAVE_REGISTERS_ON_STACK */ #endif /* not HAVE___BUILTIN_UNWIND_INIT */ - /* 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); - - /* Allow for marking a secondary stack, like the register stack on the - ia64. */ -#ifdef GC_MARK_SECONDARY_STACK - GC_MARK_SECONDARY_STACK (); -#endif + self->stack_top = end; + (*func) (arg); -#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS - check_gcpros (); -#endif + eassert (current_thread == self); } #endif /* GC_MARK_STACK != 0 */ @@ -5274,7 +5283,7 @@ See Info node `(elisp)Garbage Collection'. */) for (i = 0; i < staticidx; i++) mark_object (*staticvec[i]); - mark_specpdl (); + mark_threads (); mark_terminals (); mark_kboards (); @@ -5282,39 +5291,12 @@ See Info node `(elisp)Garbage Collection'. */) xg_mark_data (); #endif -#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ - || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) - mark_stack (); -#else - { - register struct gcpro *tail; - for (tail = gcprolist; tail; tail = tail->next) - for (i = 0; i < tail->nvars; i++) - mark_object (tail->var[i]); - } - mark_byte_stack (); - { - struct catchtag *catch; - struct handler *handler; - - for (catch = catchlist; catch; catch = catch->next) - { - mark_object (catch->tag); - mark_object (catch->val); - } - for (handler = handlerlist; handler; handler = handler->next) - { - mark_object (handler->handler); - mark_object (handler->var); - } - } -#endif - #ifdef HAVE_WINDOW_SYSTEM mark_fringe_data (); #endif #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES + FIXME; mark_stack (); #endif @@ -5364,7 +5346,7 @@ See Info node `(elisp)Garbage Collection'. */) /* Clear the mark bits that we set in certain root slots. */ - unmark_byte_stack (); + unmark_threads (); VECTOR_UNMARK (&buffer_defaults); VECTOR_UNMARK (&buffer_local_symbols); diff --git a/src/buffer.c b/src/buffer.c index 81768849a4b..19e3982a8a4 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -44,8 +44,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "keymap.h" #include "frame.h" -struct buffer *current_buffer; /* The current buffer. */ - /* First buffer in chain of all buffers (in reverse order of creation). Threaded through ->header.next.buffer. */ @@ -1734,6 +1732,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 276cca32e48..2b0b49dddad 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -1022,10 +1022,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 c79027597f8..f186f7d1bc3 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -332,19 +332,18 @@ struct byte_stack done. Signaling an error truncates the list analogous to gcprolist. */ -struct byte_stack *byte_stack_list; +/* struct byte_stack *byte_stack_list; */ /* Mark objects on byte_stack_list. Called during GC. */ #if BYTE_MARK_STACK void -mark_byte_stack (void) +mark_byte_stack (struct byte_stack *stack) { - struct byte_stack *stack; Lisp_Object *obj; - for (stack = byte_stack_list; stack; stack = stack->next) + for (; stack; stack = stack->next) { /* If STACK->top is null here, this means there's an opcode in Fbyte_code that wasn't expected to GC, but did. To find out @@ -368,11 +367,9 @@ mark_byte_stack (void) counters. Called when GC has completed. */ void -unmark_byte_stack (void) +unmark_byte_stack (struct byte_stack *stack) { - struct byte_stack *stack; - - for (stack = byte_stack_list; stack; stack = stack->next) + for (; stack; stack = stack->next) { if (stack->byte_string_start != SDATA (stack->byte_string)) { diff --git a/src/data.c b/src/data.c index dedbd51f36e..ea72a3fc181 100644 --- a/src/data.c +++ b/src/data.c @@ -80,6 +80,7 @@ static Lisp_Object Qsubrp; static Lisp_Object Qmany, Qunevalled; Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; static Lisp_Object Qdefun; +Lisp_Object Qthread, Qmutex, Qcondition_variable; Lisp_Object Qinteractive_form; static Lisp_Object Qdefalias_fset_function; @@ -286,6 +287,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: @@ -534,6 +541,36 @@ 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; + else + 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; + else + 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; + else + return Qnil; +} /* Extract and set components of lists. */ @@ -3113,6 +3150,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 (Qmisc, "misc"); DEFSYM (Qdefun, "defun"); @@ -3154,6 +3194,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 2d55cfad3d8..274321482e1 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -151,10 +151,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 (DOUG_LEA_MALLOC) || defined (GNU_LINUX) /* The address where the heap starts (from the first sbrk (0) call). */ static void *my_heap_start; @@ -674,9 +670,6 @@ close_output_streams (void) int main (int argc, char **argv) { -#if GC_MARK_STACK - Lisp_Object dummy; -#endif char stack_bottom_variable; bool do_initial_setlocale; bool dumping; @@ -692,9 +685,8 @@ main (int argc, char **argv) #endif char *ch_to_dir; -#if GC_MARK_STACK - stack_base = &dummy; -#endif + /* Record (approximately) where the stack begins. */ + stack_bottom = &stack_bottom_variable; #ifdef G_SLICE_ALWAYS_MALLOC /* This is used by the Cygwin build. */ @@ -847,9 +839,6 @@ main (int argc, char **argv) } #endif /* HAVE_SETRLIMIT and RLIMIT_STACK */ - /* Record (approximately) where the stack begins. */ - stack_bottom = &stack_bottom_variable; - clearerr (stdin); #ifndef SYSTEM_MALLOC @@ -1109,6 +1098,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 (); @@ -1155,6 +1145,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem } init_alloc (); + init_threads (); if (do_initial_setlocale) { @@ -1458,6 +1449,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 0e231bdb285..97e812dd890 100644 --- a/src/eval.c +++ b/src/eval.c @@ -32,10 +32,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "xterm.h" #endif -#if !BYTE_MARK_STACK -static -#endif -struct catchtag *catchlist; +/* #if !BYTE_MARK_STACK */ +/* static */ +/* #endif */ +/* struct catchtag *catchlist; */ /* Chain of condition handlers currently in effect. The elements of this chain are contained in the stack frames @@ -43,10 +43,10 @@ struct catchtag *catchlist; When an error is signaled (by calling Fsignal, below), this chain is searched for an element that applies. */ -#if !BYTE_MARK_STACK -static -#endif -struct handler *handlerlist; +/* #if !BYTE_MARK_STACK */ +/* static */ +/* #endif */ +/* struct handler *handlerlist; */ #ifdef DEBUG_GCPRO /* Count levels of GCPRO to detect failure to UNGCPRO. */ @@ -79,20 +79,20 @@ Lisp_Object Vautoload_queue; /* 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 @@ -146,6 +146,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); @@ -265,6 +272,19 @@ init_eval (void) when_entered_debugger = -1; } +#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ + || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) +void +mark_catchlist (struct catchtag *catch) +{ + for (; catch; catch = catch->next) + { + mark_object (catch->tag); + mark_object (catch->val); + } +} +#endif + /* Unwind-protect function used by call_debugger. */ static Lisp_Object @@ -1052,8 +1072,8 @@ internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object c.next = catchlist; c.tag = tag; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -1106,7 +1126,7 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value) /* Unwind the specpdl stack, and then restore the proper set of handlers. */ unbind_to (catchlist->pdlcount, Qnil); - handlerlist = catchlist->handlerlist; + handlerlist = catchlist->f_handlerlist; catchlist = catchlist->next; } while (! last_time); @@ -1116,7 +1136,7 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value) #ifdef DEBUG_GCPRO gcpro_level = gcprolist ? gcprolist->level + 1 : 0; #endif - lisp_eval_depth = catch->lisp_eval_depth; + lisp_eval_depth = catch->f_lisp_eval_depth; sys_longjmp (catch->jmp, 1); } @@ -1216,8 +1236,8 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, c.tag = Qnil; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -1270,8 +1290,8 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers, c.tag = Qnil; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -1307,8 +1327,8 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, c.tag = Qnil; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -1348,8 +1368,8 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), c.tag = Qnil; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -1391,8 +1411,8 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), c.tag = Qnil; c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = handlerlist; + c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); c.poll_suppress_count = poll_suppress_count; c.interrupt_input_blocked = interrupt_input_blocked; @@ -3105,6 +3125,52 @@ let_shadows_global_binding_p (Lisp_Object symbol) return 0; } +static Lisp_Object +binding_symbol (union specbinding *bind) +{ + if (!CONSP (specpdl_symbol (bind))) + return specpdl_symbol (bind); + return XCAR (specpdl_symbol (bind)); +} + +void +do_specbind (struct Lisp_Symbol *sym, union specbinding *bind, + Lisp_Object value) +{ + switch (sym->redirect) + { + case SYMBOL_PLAINVAL: + if (!sym->constant) + SET_SYMBOL_VAL (sym, value); + else + set_internal (specpdl_symbol (bind), value, Qnil, 1); + 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 (binding_symbol (bind), value, Qnil, 1); + break; + + default: + abort (); + } +} + /* `specpdl_ptr->symbol' is a field which describes which variable is let-bound, so it can be properly undone when we unbind_to. It can have the following two shapes: @@ -3139,11 +3205,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->constant) - SET_SYMBOL_VAL (sym, value); - else - set_internal (symbol, value, Qnil, 1); + do_specbind (sym, specpdl_ptr - 1, value); break; case SYMBOL_LOCALIZED: if (SYMBOL_BLV (sym)->frame_local) @@ -3155,6 +3219,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 ()))); @@ -3175,7 +3240,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; } } @@ -3183,7 +3248,7 @@ specbind (Lisp_Object symbol, Lisp_Object value) specpdl_ptr->let.kind = SPECPDL_LET; grow_specpdl (); - set_internal (symbol, value, Qnil, 1); + do_specbind (sym, specpdl_ptr - 1, value); break; } default: emacs_abort (); @@ -3199,6 +3264,73 @@ record_unwind_protect (Lisp_Object (*function) (Lisp_Object), Lisp_Object arg) 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 (binding_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: + specpdl_func (this_binding) (specpdl_arg (this_binding)); + break; + case SPECPDL_LET: + /* If variable has a trivial value (no forwarding), we can + just set it. No need to check for constant symbols here, + since that was already done by specbind. */ + if (XSYMBOL (specpdl_symbol (this_binding))->redirect + == SYMBOL_PLAINVAL) + SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (this_binding)), + specpdl_old_value (this_binding)); + else + /* NOTE: we only ever come here if make_local_foo was used for + the first time on this var within this let. */ + Fset_default (specpdl_symbol (this_binding), + specpdl_old_value (this_binding)); + break; + case SPECPDL_BACKTRACE: + break; + case SPECPDL_LET_LOCAL: + case SPECPDL_LET_DEFAULT: + { /* If the symbol is a list, it is really (SYMBOL WHERE + . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a + frame. If WHERE is a buffer or frame, this indicates we + bound a variable that had a buffer-local or frame-local + binding. WHERE nil means that the variable had the default + value when it was bound. CURRENT-BUFFER is the buffer that + was current when the variable was bound. */ + Lisp_Object symbol = specpdl_symbol (this_binding); + Lisp_Object where = specpdl_where (this_binding); + eassert (BUFFERP (where)); + + if (this_binding->kind == SPECPDL_LET_DEFAULT) + Fset_default (symbol, specpdl_old_value (this_binding)); + /* If this was a local binding, reset the value in the appropriate + buffer, but only if that buffer's binding still exists. */ + else if (!NILP (Flocal_variable_p (symbol, where))) + set_internal (symbol, specpdl_old_value (this_binding), + where, 1); + } + break; + } +} + Lisp_Object unbind_to (ptrdiff_t count, Lisp_Object value) { @@ -3210,57 +3342,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_func (specpdl_ptr) (specpdl_arg (specpdl_ptr)); - break; - case SPECPDL_LET: - /* If variable has a trivial value (no forwarding), we can - just set it. No need to check for constant symbols here, - since that was already done by specbind. */ - if (XSYMBOL (specpdl_symbol (specpdl_ptr))->redirect - == SYMBOL_PLAINVAL) - SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (specpdl_ptr)), - specpdl_old_value (specpdl_ptr)); - else - /* NOTE: we only ever come here if make_local_foo was used for - the first time on this var within this let. */ - Fset_default (specpdl_symbol (specpdl_ptr), - specpdl_old_value (specpdl_ptr)); - break; - case SPECPDL_BACKTRACE: - break; - case SPECPDL_LET_LOCAL: - case SPECPDL_LET_DEFAULT: - { /* If the symbol is a list, it is really (SYMBOL WHERE - . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a - frame. If WHERE is a buffer or frame, this indicates we - bound a variable that had a buffer-local or frame-local - binding. WHERE nil means that the variable had the default - value when it was bound. CURRENT-BUFFER is the buffer that - was current when the variable was bound. */ - 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 (specpdl_ptr->kind == SPECPDL_LET_DEFAULT) - Fset_default (symbol, old_value); - /* If this was a local binding, reset the value in the appropriate - buffer, but only if that buffer's binding still exists. */ - else if (!NILP (Flocal_variable_p (symbol, where))) - set_internal (symbol, old_value, where, 1); - } - break; - } + do_one_unbind (&this_binding, 1); } if (NILP (Vquit_flag) && !NILP (quitf)) @@ -3270,6 +3361,21 @@ unbind_to (ptrdiff_t count, Lisp_Object value) return value; } +void +unbind_for_thread_switch (void) +{ + union specbinding *bind; + + for (bind = specpdl_ptr; bind != specpdl; --bind) + { + if (bind->kind >= SPECPDL_LET) + { + bind->let.saved_value = find_symbol_value (binding_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 @@ -3379,10 +3485,10 @@ If NFRAMES is more than the number of frames, the value is nil. */) 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) { @@ -3408,6 +3514,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; } } diff --git a/src/lisp.h b/src/lisp.h index a54b2e07057..acd21089655 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -32,6 +32,8 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <intprops.h> +#include "systhread.h" + INLINE_HEADER_BEGIN #ifndef LISP_INLINE # define LISP_INLINE INLINE @@ -503,6 +505,39 @@ typedef EMACS_INT Lisp_Object; enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = 0 }; #endif /* CHECK_LISP_OBJECT_TYPE */ +/* 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 + <http://debbugs.gnu.org/cgi/bugreport.cgi?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. */ LISP_MACRO_DEFUN (XLI, EMACS_INT, (Lisp_Object o), (o)) @@ -537,6 +572,9 @@ enum pvec_type PVEC_WINDOW_CONFIGURATION, PVEC_SUBR, PVEC_OTHER, + PVEC_THREAD, + PVEC_MUTEX, + PVEC_CONDVAR, /* These should be last, check internal_equal to see why. */ PVEC_COMPILED, PVEC_CHAR_TABLE, @@ -723,6 +761,9 @@ LISP_INLINE bool SUBRP (Lisp_Object); LISP_INLINE bool (SYMBOLP) (Lisp_Object); LISP_INLINE bool (VECTORLIKEP) (Lisp_Object); LISP_INLINE bool WINDOWP (Lisp_Object); +LISP_INLINE bool THREADP (Lisp_Object); +LISP_INLINE bool MUTEXP (Lisp_Object); +LISP_INLINE bool CONDVARP (Lisp_Object); LISP_INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object); /* Defined in chartab.c. */ @@ -750,6 +791,9 @@ extern double extract_float (Lisp_Object); /* Defined in process.c. */ extern Lisp_Object Qprocessp; +/* Defined in thread.c. */ +extern Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep; + /* Defined in window.c. */ extern Lisp_Object Qwindowp; @@ -841,6 +885,27 @@ XBOOL_VECTOR (Lisp_Object a) return XUNTAG (a, Lisp_Vectorlike); } +LISP_INLINE struct thread_state * +XTHREAD (Lisp_Object a) +{ + eassert (THREADP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +LISP_INLINE struct Lisp_Mutex * +XMUTEX (Lisp_Object a) +{ + eassert (MUTEXP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +LISP_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. */ LISP_INLINE Lisp_Object @@ -905,6 +970,9 @@ make_lisp_proc (struct Lisp_Process *p) #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)) /* Type checking. */ @@ -1104,37 +1172,6 @@ STRING_COPYIN (Lisp_Object string, ptrdiff_t index, char const *new, memcpy (SDATA (string) + index, new, count); } -/* 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 - <http://debbugs.gnu.org/cgi/bugreport.cgi?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; - }; - /* Regular vector is just a header plus array of Lisp_Objects. */ struct Lisp_Vector @@ -2371,6 +2408,24 @@ FRAMEP (Lisp_Object a) return PSEUDOVECTORP (a, PVEC_FRAME); } +LISP_INLINE bool +THREADP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_THREAD); +} + +LISP_INLINE bool +MUTEXP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_MUTEX); +} + +LISP_INLINE bool +CONDVARP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_CONDVAR); +} + /* Test for image (image . spec) */ LISP_INLINE bool IMAGEP (Lisp_Object x) @@ -2485,6 +2540,25 @@ CHECK_NUMBER_OR_FLOAT (Lisp_Object x) do { if (MARKERP (x)) XSETFASTINT (x, marker_position (x)); \ else CHECK_TYPE (INTEGERP (x) || FLOATP (x), Qnumber_or_marker_p, x); } while (0) + +LISP_INLINE void +CHECK_THREAD (Lisp_Object x) +{ + CHECK_TYPE (THREADP (x), Qthreadp, x); +} + +LISP_INLINE void +CHECK_MUTEX (Lisp_Object x) +{ + CHECK_TYPE (MUTEXP (x), Qmutexp, x); +} + +LISP_INLINE void +CHECK_CONDVAR (Lisp_Object x) +{ + CHECK_TYPE (CONDVARP (x), Qcondition_variablep, 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. */ LISP_INLINE void @@ -2724,6 +2798,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; @@ -2734,9 +2811,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; */ LISP_INLINE ptrdiff_t SPECPDL_INDEX (void) @@ -2802,8 +2879,8 @@ struct catchtag struct gcpro *gcpro; #endif sys_jmp_buf jmp; - struct handler *handlerlist; - EMACS_INT lisp_eval_depth; + struct handler *f_handlerlist; + EMACS_INT f_lisp_eval_depth; ptrdiff_t volatile pdlcount; int poll_suppress_count; int interrupt_input_blocked; @@ -2812,10 +2889,6 @@ struct catchtag 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. @@ -2865,8 +2938,6 @@ extern Lisp_Object Vascii_canon_table; Every function that can call Feval must protect in this fashion all Lisp_Object variables whose contents will be used again. */ -extern struct gcpro *gcprolist; - struct gcpro { struct gcpro *next; @@ -2975,8 +3046,6 @@ struct gcpro #else -extern int gcpro_level; - #define GCPRO1(varname) \ {gcpro1.next = gcprolist; gcpro1.var = &varname; gcpro1.nvars = 1; \ gcpro1.level = gcpro_level++; \ @@ -3462,9 +3531,12 @@ extern void mark_object (Lisp_Object); #if defined REL_ALLOC && !defined SYSTEM_MALLOC extern void refill_memory_reserve (void); #endif +#if GC_MARK_STACK +extern void mark_stack (char *, char *); +#endif +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; @@ -3696,9 +3768,10 @@ extern Lisp_Object Qand_rest; extern Lisp_Object Vautoload_queue; extern Lisp_Object Vsignaling_function; extern Lisp_Object inhibit_lisp_code; -#if BYTE_MARK_STACK -extern struct catchtag *catchlist; -extern struct handler *handlerlist; +extern int handling_signal; +#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ + || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) +extern void mark_catchlist (struct catchtag *); #endif /* To run a normal hook, use the appropriate function from the list below. The calling convention: @@ -3740,6 +3813,8 @@ extern Lisp_Object internal_condition_case_n extern void specbind (Lisp_Object, Lisp_Object); extern void record_unwind_protect (Lisp_Object (*) (Lisp_Object), Lisp_Object); extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object); +extern void rebind_for_thread_switch (void); +extern void unbind_for_thread_switch (void); extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); extern _Noreturn void verror (const char *, va_list) ATTRIBUTE_FORMAT_PRINTF (1, 0); @@ -3753,13 +3828,16 @@ extern void init_eval (void); extern void syms_of_eval (void); extern void record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs); -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); extern bool let_shadows_global_binding_p (Lisp_Object symbol); +/* Defined in thread.c. */ +extern void mark_threads (void); + /* Defined in editfns.c. */ extern Lisp_Object Qfield; extern void insert1 (Lisp_Object); @@ -4023,11 +4101,10 @@ extern int read_bytecode_char (bool); /* Defined in bytecode.c. */ extern void syms_of_bytecode (void); -extern struct byte_stack *byte_stack_list; #if BYTE_MARK_STACK -extern void mark_byte_stack (void); +extern void mark_byte_stack (struct byte_stack *); #endif -extern void unmark_byte_stack (void); +extern void unmark_byte_stack (struct byte_stack *); extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, ptrdiff_t, Lisp_Object *); diff --git a/src/print.c b/src/print.c index 8ea76d98854..01e490dcbad 100644 --- a/src/print.c +++ b/src/print.c @@ -1938,6 +1938,42 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) } PRINTCHAR ('>'); } + else if (THREADP (obj)) + { + strout ("#<thread ", -1, -1, 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 ('>'); + } + else if (MUTEXP (obj)) + { + strout ("#<mutex ", -1, -1, 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 ('>'); + } + else if (CONDVARP (obj)) + { + strout ("#<condvar ", -1, -1, 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 ('>'); + } else { ptrdiff_t size = ASIZE (obj); diff --git a/src/process.c b/src/process.c index 4a38c47443a..dc37bfe7067 100644 --- a/src/process.c +++ b/src/process.c @@ -296,38 +296,13 @@ static void create_pty (Lisp_Object); static Lisp_Object get_process (register Lisp_Object name); static void exec_sentinel (Lisp_Object proc, Lisp_Object reason); -/* Mask of bits indicating the descriptors that we wait for input on. */ - -static SELECT_TYPE input_wait_mask; - -/* Mask that excludes keyboard input descriptor(s). */ - -static SELECT_TYPE non_keyboard_wait_mask; - -/* Mask that excludes process input descriptor(s). */ - -static SELECT_TYPE non_process_wait_mask; - -/* Mask for selecting for write. */ - -static SELECT_TYPE write_mask; - #ifdef NON_BLOCKING_CONNECT -/* 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 SELECT_TYPE connect_wait_mask; - /* Number of bits set in connect_wait_mask. */ static int num_pending_connects; #endif /* NON_BLOCKING_CONNECT */ -/* The largest descriptor currently in use for a process object. */ -static int max_process_desc; - /* The largest descriptor currently in use for input. */ -static int max_input_desc; +static int max_desc; /* Indexed by descriptor, gives the process (if any) for that descriptor */ static Lisp_Object chan_process[MAXDESC]; @@ -407,6 +382,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; @@ -444,13 +424,34 @@ pset_write_queue (struct Lisp_Process *p, Lisp_Object val) +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[MAXDESC]; @@ -465,7 +466,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 < MAXDESC); + 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. */ @@ -474,10 +491,10 @@ void delete_read_fd (int fd) { eassert (fd < MAXDESC); + eassert (fd <= max_desc); 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; @@ -491,13 +508,39 @@ void add_write_fd (int fd, fd_callback func, void *data) { eassert (fd < MAXDESC); - 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; +} + +static void +add_non_blocking_write_fd (int fd) +{ + eassert (fd >= 0 && fd < MAXDESC); + 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 +recompute_max_desc (void) +{ + int fd; + + for (fd = max_desc; fd >= 0; --fd) + { + if (fd_callback_info[fd].flags != 0) + { + max_desc = fd; + break; + } + } } /* Stop monitoring file descriptor FD for when write is possible. */ @@ -505,24 +548,126 @@ add_write_fd (int fd, fd_callback func, void *data) void delete_write_fd (int fd) { - int lim = max_input_desc; + int lim = max_desc; eassert (fd < MAXDESC); - FD_CLR (fd, &write_mask); - fd_callback_info[fd].condition &= ~FOR_WRITE; - if (fd_callback_info[fd].condition == 0) + eassert (fd <= max_desc); + + if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0) + { + if (--num_pending_connects < 0) + 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; - if (fd == max_input_desc) - for (fd = lim; fd >= 0; fd--) - if (FD_ISSET (fd, &input_wait_mask) || FD_ISSET (fd, &write_mask)) - { - max_input_desc = fd; - break; - } + if (fd == max_desc) + recompute_max_desc (); + } +} + +static void +compute_input_wait_mask (SELECT_TYPE *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 (SELECT_TYPE *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 (SELECT_TYPE *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 (SELECT_TYPE *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; } } @@ -714,6 +859,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. */ @@ -753,6 +899,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; + } + } +} + DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0, doc: /* Return t if OBJECT is a process. */) @@ -1051,17 +1218,11 @@ The string argument is normally a multibyte string, except: if (p->infd >= 0) { if (EQ (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); - } + delete_read_fd (p->infd); } pset_filter (p, filter); @@ -1112,6 +1273,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 HEIGHT and WIDTH. */) @@ -1687,10 +1884,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) XPROCESS (process)->pty_flag = pty_flag; pset_status (XPROCESS (process), Qrun); - 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); @@ -1953,10 +2147,7 @@ create_pty (Lisp_Object process) pset_status (XPROCESS (process), Qrun); setup_process_coding_systems (process); - 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); XPROCESS (process)->pid = -2; #ifdef HAVE_PTYS @@ -2578,8 +2769,8 @@ usage: (make-serial-process &rest ARGS) */) fd = serial_open (SSDATA (port)); 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); @@ -2601,10 +2792,7 @@ usage: (make-serial-process &rest ARGS) */) p->pty_flag = 0; 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)) { @@ -3403,12 +3591,8 @@ usage: (make-network-process &rest ARGS) */) in that case, we still need to signal this like a non-blocking connection. */ pset_status (p, Qconnect); - 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 #endif @@ -3416,13 +3600,10 @@ usage: (make-network-process &rest ARGS) */) 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; tem = Fplist_member (contact, QCcoding); if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) @@ -3863,27 +4044,13 @@ deactivate_process (Lisp_Object proc) } #endif chan_process[inchannel] = Qnil; - FD_CLR (inchannel, &input_wait_mask); - FD_CLR (inchannel, &non_keyboard_wait_mask); + delete_read_fd (inchannel); #ifdef NON_BLOCKING_CONNECT - 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 ((fd_callback_info[inchannel].flags & NON_BLOCKING_CONNECT_FD) != 0) + delete_write_fd (inchannel); #endif - if (inchannel == max_process_desc) - { - int i; - /* We just closed the highest-numbered process input descriptor, - so recompute the highest-numbered one now. */ - max_process_desc = 0; - for (i = 0; i < MAXDESC; i++) - if (!NILP (chan_process[i])) - max_process_desc = i; - } + if (inchannel == max_desc) + recompute_max_desc (); } } @@ -3911,7 +4078,17 @@ Return non-nil if we received any output 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; @@ -4131,13 +4308,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 @@ -4167,20 +4338,10 @@ server_accept_connection (Lisp_Object server, int channel) build_string ("\n"))); } -/* 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 Lisp_Object wait_reading_process_output_unwind (Lisp_Object data) { + clear_waiting_thread_info (); waiting_for_user_input_p = XINT (data); return Qnil; } @@ -4248,6 +4409,10 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, bool got_some_input = 0; ptrdiff_t count = SPECPDL_INDEX (); + eassert (wait_proc == NULL + || EQ (wait_proc->thread, Qnil) + || XTHREAD (wait_proc->thread) == current_thread); + FD_ZERO (&Available); FD_ZERO (&Writeok); @@ -4397,18 +4562,18 @@ 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_emacs_time (0, 0); - if ((pselect (max (max_process_desc, max_input_desc) + 1, - &Atemp, + if ((thread_select (pselect, max_desc + 1, + &Atemp, #ifdef NON_BLOCKING_CONNECT - (num_pending_connects > 0 ? &Ctemp : NULL), + (num_pending_connects > 0 ? &Ctemp : NULL), #else - NULL, + NULL, #endif - NULL, &timeout, NULL) + NULL, &timeout, NULL) <= 0)) { /* It's okay for us to do this and then continue with @@ -4467,17 +4632,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); #ifdef SELECT_CANT_DO_WRITE_MASK check_write = 0; #else @@ -4525,7 +4690,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, int nsecs = EMACS_NSECS (timeout); if (EMACS_SECS (timeout) > 0 || nsecs > READ_OUTPUT_DELAY_MAX) 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)) @@ -4547,18 +4712,18 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, process_output_skip = 0; } #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 : (SELECT_TYPE *)0), - NULL, &timeout, NULL); + , max_desc + 1, + &Available, + (check_write ? &Writeok : (SELECT_TYPE *)0), + NULL, &timeout, NULL); #ifdef HAVE_GNUTLS /* GnuTLS buffers data internally. In lowat mode it leaves @@ -4713,22 +4878,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; @@ -4796,8 +4961,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) { @@ -4827,14 +4991,12 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } #ifdef NON_BLOCKING_CONNECT 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)) @@ -4881,10 +5043,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, from the process before calling the sentinel. */ exec_sentinel (proc, build_string ("open\n")); if (!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); } } #endif /* NON_BLOCKING_CONNECT */ @@ -5870,10 +6029,7 @@ 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; } @@ -5901,8 +6057,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); @@ -6191,10 +6346,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); } } } @@ -6544,9 +6696,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; @@ -6791,10 +6943,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 < MAXDESC); + fd_callback_info[desc].flags |= FOR_READ | KEYBOARD_FD; + if (desc > max_desc) + max_desc = desc; #endif } @@ -6805,15 +6957,15 @@ delete_keyboard_wait_descriptor (int desc) { #ifdef subprocesses int fd; - int lim = max_input_desc; + int lim = max_desc; + + eassert (desc >= 0 && desc < MAXDESC); + eassert (desc <= max_desc); - FD_CLR (desc, &input_wait_mask); - FD_CLR (desc, &non_process_wait_mask); + fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD); - if (desc == max_input_desc) - for (fd = 0; fd < lim; fd++) - if (FD_ISSET (fd, &input_wait_mask) || FD_ISSET (fd, &write_mask)) - max_input_desc = fd; + if (desc == max_desc) + recompute_max_desc (); #endif } @@ -7074,15 +7226,10 @@ init_process_emacs (void) catch_child_signal (); } - FD_ZERO (&input_wait_mask); - FD_ZERO (&non_keyboard_wait_mask); - FD_ZERO (&non_process_wait_mask); - FD_ZERO (&write_mask); - max_process_desc = 0; + max_desc = 0; memset (fd_callback_info, 0, sizeof (fd_callback_info)); #ifdef NON_BLOCKING_CONNECT - FD_ZERO (&connect_wait_mask); num_pending_connects = 0; #endif @@ -7314,6 +7461,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 8ae33aebf39..89c7e8b1259 100644 --- a/src/process.h +++ b/src/process.h @@ -103,6 +103,9 @@ struct Lisp_Process Lisp_Object gnutls_cred_type; #endif + /* 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. */ @@ -231,4 +234,6 @@ extern void delete_write_fd (int fd); extern void catch_child_signal (void); #endif +extern void update_processes_for_thread_death (Lisp_Object); + INLINE_HEADER_END diff --git a/src/regex.c b/src/regex.c index 39adb080efd..5024f748884 100644 --- a/src/regex.c +++ b/src/regex.c @@ -1212,12 +1212,14 @@ print_double_string (re_char *where, re_char *string1, ssize_t size1, # define IF_LINT(Code) /* empty */ #endif +#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 @@ -1237,8 +1239,10 @@ 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 re_char *whitespace_regexp; +#endif void re_set_whitespace_regexp (const char *regexp) @@ -4883,12 +4887,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. It is used for looking up syntax properties. */ -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 bb737df5239..31be0504c9e 100644 --- a/src/regex.h +++ b/src/regex.h @@ -164,12 +164,12 @@ typedef unsigned long int 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 /* In Emacs, this is the string or buffer in which we are matching. It is used for looking up syntax properties. */ -extern Lisp_Object re_match_object; +/* extern Lisp_Object re_match_object; */ #endif diff --git a/src/search.c b/src/search.c index 19cc08f84c4..ff47bb2fecf 100644 --- a/src/search.c +++ b/src/search.c @@ -42,7 +42,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. */ @@ -77,12 +77,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; */ /* Error condition signaled when regexp compile_pattern fails. */ static Lisp_Object Qinvalid_regexp; @@ -130,9 +130,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. @@ -232,7 +232,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; @@ -2972,9 +2972,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. */ @@ -3078,10 +3078,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/systhread.c b/src/systhread.c new file mode 100644 index 00000000000..ab647528452 --- /dev/null +++ b/src/systhread.c @@ -0,0 +1,131 @@ +/* System thread definitions + 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/>. */ + +#include <config.h> +#include <setjmp.h> +#include "lisp.h" + +#ifdef 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 (); +} + +#else + +#error port me + +#endif diff --git a/src/systhread.h b/src/systhread.h new file mode 100644 index 00000000000..bbd242ab93c --- /dev/null +++ b/src/systhread.h @@ -0,0 +1,63 @@ +/* System thread definitions + 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/>. */ + +#ifndef SYSTHREAD_H +#define SYSTHREAD_H + +#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 + +#error port me + +#endif + +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/systime.h b/src/systime.h index df733b290c3..657f2cca11f 100644 --- a/src/systime.h +++ b/src/systime.h @@ -154,8 +154,8 @@ extern void set_waiting_for_input (EMACS_TIME *); /* When lisp.h is not included Lisp_Object is not defined (this can happen when this files is used outside the src directory). - Use GCPRO1 to determine if lisp.h was included. */ -#ifdef GCPRO1 + Use GCTYPEBITS to determine if lisp.h was included. */ +#ifdef GCTYPEBITS /* defined in editfns.c */ extern Lisp_Object make_lisp_time (EMACS_TIME); extern bool decode_time_components (Lisp_Object, Lisp_Object, Lisp_Object, diff --git a/src/thread.c b/src/thread.c new file mode 100644 index 00000000000..4c6b6543c84 --- /dev/null +++ b/src/thread.c @@ -0,0 +1,965 @@ +/* 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; + +Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep; + + + +/* 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; + + if (self != current_thread) + { + /* CURRENT_THREAD is NULL if the previously current thread + exited. In this case, there is no reason to unbind, and + trying will crash. */ + if (current_thread != NULL) + unbind_for_thread_switch (); + current_thread = self; + 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 Lisp_Object +do_unwind_mutex_lock (Lisp_Object ignore) +{ + current_thread->event_object = Qnil; + return 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 (do_unwind_mutex_lock, Qnil); + 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; + SELECT_TYPE *rfds; + SELECT_TYPE *wfds; + SELECT_TYPE *efds; + EMACS_TIME *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, SELECT_TYPE *rfds, + SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *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); + +#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ + || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) + mark_stack (thread->m_stack_bottom, thread->stack_top); +#else + { + struct gcpro *tail; + for (tail = thread->m_gcprolist; tail; tail = tail->next) + for (i = 0; i < tail->nvars; i++) + mark_object (tail->var[i]); + } + +#if BYTE_MARK_STACK + if (thread->m_byte_stack_list) + mark_byte_stack (thread->m_byte_stack_list); +#endif + + mark_catchlist (thread->m_catchlist); + + for (handler = thread->m_handlerlist; handler; handler = handler->next) + { + mark_object (handler->handler); + mark_object (handler->var); + } +#endif + + 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) + unmark_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); + + /* 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; + + 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; + + /* Can't start a thread in temacs. */ + if (!initialized) + abort (); + + if (!NILP (name)) + CHECK_STRING (name); + + new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_gcprolist, + PVEC_THREAD); + memset ((char *) new_thread + offsetof (struct thread_state, m_gcprolist), + 0, sizeof (struct thread_state) - offsetof (struct thread_state, + m_gcprolist)); + + 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; +} + + + +int +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 1; + } + + return 0; +} + + + +static void +init_primary_thread (void) +{ + primary_thread.header.size + = PSEUDOVECSIZE (struct thread_state, m_gcprolist); + 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) +{ + 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); + + Qthreadp = intern_c_string ("threadp"); + staticpro (&Qthreadp); + Qmutexp = intern_c_string ("mutexp"); + staticpro (&Qmutexp); + Qcondition_variablep = intern_c_string ("condition-variablep"); + staticpro (&Qcondition_variablep); +} diff --git a/src/thread.h b/src/thread.h new file mode 100644 index 00000000000..e77d1144ecf --- /dev/null +++ b/src/thread.h @@ -0,0 +1,244 @@ +/* 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" + +#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_gcprolist must be the first non-lisp field. */ + /* Recording what needs to be marked for gc. */ + struct gcpro *m_gcprolist; +#define gcprolist (current_thread->m_gcprolist) + + /* 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 analoguous to + gcprolist. */ + 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) + + /* Count levels of GCPRO to detect failure to UNGCPRO. */ + int m_gcpro_level; +#define gcpro_level (current_thread->m_gcpro_level) + + /* 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. */ + 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. */ + /*re_char*/ unsigned char *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, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, + EMACS_TIME *, sigset_t *); + +int thread_select (select_func *func, int max_fds, SELECT_TYPE *rfds, + SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *timeout, + sigset_t *sigmask); + +int thread_check_current_buffer (struct buffer *); + +#endif /* THREAD_H */ diff --git a/src/window.c b/src/window.c index 22da72db2b7..ba9728f09af 100644 --- a/src/window.c +++ b/src/window.c @@ -5445,7 +5445,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; @@ -5525,7 +5525,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 @@ -6134,7 +6134,7 @@ saved by this function. */) data->frame_tool_bar_lines = FRAME_TOOL_BAR_LINES (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); @@ -6528,7 +6528,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 4d90298a9d9..15ee59dfa81 100644 --- a/src/xgselect.c +++ b/src/xgselect.c @@ -40,8 +40,7 @@ xg_select (int fds_lim, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, GPollFD *gfds = gfds_buf; int gfds_size = sizeof gfds_buf / sizeof *gfds_buf; int n_gfds, retval = 0, our_fds = 0, max_fds = fds_lim - 1; - int i, nfds, tmo_in_millisec; - USE_SAFE_ALLOCA; + int i, nfds, tmo_in_millisec, must_free = 0; /* Do not try to optimize with an initial check with g_main_context_pending and a call to pselect if it returns false. If Gdk has a timeout for 0.01 @@ -60,7 +59,8 @@ xg_select (int fds_lim, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, gfds, gfds_size); 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); @@ -81,7 +81,8 @@ xg_select (int fds_lim, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, } } - SAFE_FREE (); + if (must_free) + xfree (gfds); if (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 |