syntax.o $(UNEXEC_OBJ) bytecode.o \
process.o gnutls.o callproc.o \
region-cache.o sound.o atimer.o \
- doprnt.o intervals.o textprop.o composite.o xml.o inotify.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)
obj = $(base_obj) $(NS_OBJC_OBJ)
#ifdef WINDOWSNT
syms_of_ntterm ();
+ #ifdef HAVE_W32NOTIFY
syms_of_w32notify ();
+ #endif /* HAVE_W32NOTIFY */
#endif /* WINDOWSNT */
+ syms_of_threads ();
syms_of_profiler ();
keys_of_casefiddle ();
#include "xterm.h"
#endif
- /* static struct backtrace *backtrace_list; */
-
-#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
c.next = catchlist;
c.tag = tag;
c.val = Qnil;
- c.backlist = backtrace_list;
- 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;
#ifdef DEBUG_GCPRO
gcpro_level = gcprolist ? gcprolist->level + 1 : 0;
#endif
- backtrace_list = catch->backlist;
- lisp_eval_depth = catch->lisp_eval_depth;
+ lisp_eval_depth = catch->f_lisp_eval_depth;
sys_longjmp (catch->jmp, 1);
}
c.tag = Qnil;
c.val = Qnil;
- c.backlist = backtrace_list;
- 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;
c.tag = Qnil;
c.val = Qnil;
- c.backlist = backtrace_list;
- 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;
c.tag = Qnil;
c.val = Qnil;
- c.backlist = backtrace_list;
- 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;
c.tag = Qnil;
c.val = Qnil;
- c.backlist = backtrace_list;
- 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;
c.tag = Qnil;
c.val = Qnil;
- c.backlist = backtrace_list;
- 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;
return object;
}
\f
- static void
- grow_specpdl (void)
+ /* Return true if SYMBOL currently has a let-binding
+ which was made in the buffer that is now current. */
+
+ bool
+ let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
{
- register ptrdiff_t count = SPECPDL_INDEX ();
- ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX);
- if (max_size <= specpdl_size)
- {
- if (max_specpdl_size < 400)
- max_size = max_specpdl_size = 400;
- if (max_size <= specpdl_size)
- signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil);
- }
- specpdl = xpalloc (specpdl, &specpdl_size, 1, max_size, sizeof *specpdl);
- specpdl_ptr = specpdl + count;
+ struct specbinding *p;
+ Lisp_Object buf = Fcurrent_buffer ();
+
+ for (p = specpdl_ptr; p > specpdl; )
+ if ((--p)->kind > SPECPDL_LET)
+ {
+ struct Lisp_Symbol *let_bound_symbol = XSYMBOL (specpdl_symbol (p));
+ eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS);
+ if (symbol == let_bound_symbol
+ && EQ (specpdl_where (p), buf))
+ return 1;
+ }
+
+ return 0;
+ }
+
+ bool
+ let_shadows_global_binding_p (Lisp_Object symbol)
+ {
+ struct specbinding *p;
+
+ for (p = specpdl_ptr; p > specpdl; )
+ if ((--p)->kind >= SPECPDL_LET && EQ (specpdl_symbol (p), symbol))
+ return 1;
+
+ return 0;
}
+static Lisp_Object
+binding_symbol (const struct specbinding *bind)
+{
+ if (!CONSP (bind->symbol))
+ return bind->symbol;
+ return XCAR (bind->symbol);
+}
+
+void
+do_specbind (struct Lisp_Symbol *sym, struct specbinding *bind,
+ Lisp_Object value)
+{
+ switch (sym->redirect)
+ {
+ case SYMBOL_PLAINVAL:
+ if (!sym->constant)
+ SET_SYMBOL_VAL (sym, value);
+ else
+ set_internal (bind->symbol, value, Qnil, 1);
+ break;
+
+ case SYMBOL_LOCALIZED:
+ case SYMBOL_FORWARDED:
+ if ((sym->redirect == SYMBOL_LOCALIZED
+ || BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
+ && CONSP (bind->symbol))
+ {
+ Lisp_Object where;
+
+ where = XCAR (XCDR (bind->symbol));
+ if (NILP (where)
+ && sym->redirect == SYMBOL_FORWARDED)
+ {
+ Fset_default (XCAR (bind->symbol), 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:
case SYMBOL_PLAINVAL:
/* The most common case is that of a non-constant symbol with a
trivial value. Make that as fast as we can. */
- set_specpdl_symbol (symbol);
- set_specpdl_old_value (SYMBOL_VAL (sym));
- specpdl_ptr->func = NULL;
- specpdl_ptr->saved_value = Qnil;
+ specpdl_ptr->kind = SPECPDL_LET;
+ specpdl_ptr->v.let.symbol = symbol;
+ specpdl_ptr->v.let.old_value = SYMBOL_VAL (sym);
++ specpdl_ptr->v.let.saved_value = Qnil;
++specpdl_ptr;
- 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)
value by changing the value of SYMBOL in all buffers not
having their own value. This is consistent with what
happens with other buffer-local variables. */
- if (NILP (where)
- && sym->redirect == SYMBOL_FORWARDED)
+ if (NILP (Flocal_variable_p (symbol, Qnil)))
{
- eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym)));
+ specpdl_ptr->kind = SPECPDL_LET_DEFAULT;
++specpdl_ptr;
- Fset_default (symbol, value);
+ do_specbind (sym, specpdl_ptr - 1, value);
return;
}
}
else
- set_specpdl_symbol (symbol);
+ specpdl_ptr->kind = SPECPDL_LET;
specpdl_ptr++;
- set_internal (symbol, value, Qnil, 1);
+ do_specbind (sym, specpdl_ptr - 1, value);
break;
}
default: emacs_abort ();
specpdl_ptr++;
}
- if (bind->func == NULL)
+void
+rebind_for_thread_switch (void)
+{
+ struct specbinding *bind;
+
+ for (bind = specpdl; bind != specpdl_ptr; ++bind)
+ {
- if (this_binding->func != 0)
- (*this_binding->func) (this_binding->old_value);
- /* 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. */
- else if (CONSP (this_binding->symbol))
- {
- Lisp_Object symbol, where;
-
- symbol = XCAR (this_binding->symbol);
- where = XCAR (XCDR (this_binding->symbol));
-
- if (NILP (where))
- Fset_default (symbol, this_binding->old_value);
- /* If `where' is non-nil, reset the value in the appropriate
- local binding, but only if that binding still exists. */
- else if (BUFFERP (where)
- ? !NILP (Flocal_variable_p (symbol, where))
- : !NILP (Fassq (symbol, XFRAME (where)->param_alist)))
- set_internal (symbol, this_binding->old_value, where, 1);
- }
- /* 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. */
- else if (XSYMBOL (this_binding->symbol)->redirect == SYMBOL_PLAINVAL)
- SET_SYMBOL_VAL (XSYMBOL (this_binding->symbol),
- this_binding->old_value);
- 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 (this_binding->symbol, this_binding->old_value);
++ if (bind->kind >= SPECPDL_LET)
+ {
+ Lisp_Object value = bind->saved_value;
+
+ bind->saved_value = Qnil;
+ do_specbind (XSYMBOL (binding_symbol (bind)), bind, value);
+ }
+ }
+}
+
+static void
+do_one_unbind (const struct specbinding *this_binding, int unwinding)
+{
++ 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)
{
return value;
}
- if (bind->func == NULL)
+void
+unbind_for_thread_switch (void)
+{
+ struct specbinding *bind;
+
+ for (bind = specpdl_ptr; bind != specpdl; --bind)
+ {
++ if (bind->kind >= SPECPDL_LET)
+ {
+ bind->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
}
\f
- #if BYTE_MARK_STACK
void
- mark_backtrace (void)
-mark_specpdl (void)
++mark_specpdl (struct specbinding *first, struct specbinding *ptr)
{
- register struct backtrace *backlist;
- ptrdiff_t i;
-
- for (backlist = backtrace_list; backlist; backlist = backlist->next)
+ struct specbinding *pdl;
- for (pdl = specpdl; pdl != specpdl_ptr; pdl++)
++ for (pdl = first; pdl != ptr; pdl++)
{
- mark_object (backlist->function);
+ switch (pdl->kind)
+ {
+ case SPECPDL_UNWIND:
+ mark_object (specpdl_arg (pdl));
+ break;
+ case SPECPDL_BACKTRACE:
+ {
+ ptrdiff_t nargs = backtrace_nargs (pdl);
+ mark_object (backtrace_function (pdl));
+ if (nargs == UNEVALLED)
+ nargs = 1;
+ while (nargs--)
+ mark_object (backtrace_args (pdl)[nargs]);
+ }
+ break;
+ case SPECPDL_LET_DEFAULT:
+ case SPECPDL_LET_LOCAL:
+ mark_object (specpdl_where (pdl));
+ case SPECPDL_LET:
+ mark_object (specpdl_symbol (pdl));
+ mark_object (specpdl_old_value (pdl));
++ mark_object (specpdl_saved_value (pdl));
+ }
+ }
+ }
+
+ void
+ get_backtrace (Lisp_Object array)
+ {
+ struct specbinding *pdl = backtrace_next (backtrace_top ());
+ ptrdiff_t i = 0, asize = ASIZE (array);
- if (backlist->nargs == UNEVALLED
- || backlist->nargs == MANY) /* FIXME: Can this happen? */
- i = 1;
+ /* Copy the backtrace contents into working memory. */
+ for (; i < asize; i++)
+ {
+ if (backtrace_p (pdl))
+ {
+ ASET (array, i, backtrace_function (pdl));
+ pdl = backtrace_next (pdl);
+ }
else
- i = backlist->nargs;
- while (i--)
- mark_object (backlist->args[i]);
+ ASET (array, i, Qnil);
}
}
- #endif
+
+ Lisp_Object backtrace_top_function (void)
+ {
+ struct specbinding *pdl = backtrace_top ();
+ return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil);
+ }
void
syms_of_eval (void)
typedef Lisp_Object (*specbinding_func) (Lisp_Object);
+ enum specbind_tag {
+ SPECPDL_UNWIND, /* An unwind_protect function. */
+ SPECPDL_BACKTRACE, /* An element of the backtrace. */
+ SPECPDL_LET, /* A plain and simple dynamic let-binding. */
+ /* Tags greater than SPECPDL_LET must be "subkinds" of LET. */
+ SPECPDL_LET_LOCAL, /* A buffer-local let-binding. */
+ SPECPDL_LET_DEFAULT /* A global binding for a localized var. */
+ };
+
struct specbinding
{
- Lisp_Object symbol, old_value;
- specbinding_func func;
- /* Normally this is unused; but it is to the symbol's current
- value when a thread is swapped out. */
- Lisp_Object saved_value;
+ enum specbind_tag kind;
+ union {
+ struct {
+ Lisp_Object arg;
+ specbinding_func func;
+ } unwind;
+ struct {
+ /* `where' is not used in the case of SPECPDL_LET. */
+ Lisp_Object symbol, old_value, where;
++ /* Normally this is unused; but it is to the symbol's current
++ value when a thread is swapped out. */
++ Lisp_Object saved_value;
+ } let;
+ struct {
+ Lisp_Object function;
+ Lisp_Object *args;
+ ptrdiff_t nargs : BITS_PER_PTRDIFF_T - 1;
+ bool debug_on_exit : 1;
+ } bt;
+ } v;
};
- #define SPECPDL_INDEX() (specpdl_ptr - specpdl)
+ LISP_INLINE Lisp_Object specpdl_symbol (struct specbinding *pdl)
+ { eassert (pdl->kind >= SPECPDL_LET); return pdl->v.let.symbol; }
- struct backtrace
- {
- struct backtrace *next;
- Lisp_Object function;
- Lisp_Object *args; /* Points to vector of args. */
- ptrdiff_t nargs; /* Length of vector. */
- /* Nonzero means call value of debugger when done with this operation. */
- unsigned int debug_on_exit : 1;
- };
+ LISP_INLINE Lisp_Object specpdl_old_value (struct specbinding *pdl)
+ { eassert (pdl->kind >= SPECPDL_LET); return pdl->v.let.old_value; }
+
++LISP_INLINE Lisp_Object specpdl_saved_value (struct specbinding *pdl)
++{ eassert (pdl->kind >= SPECPDL_LET); return pdl->v.let.saved_value; }
+
- extern struct backtrace *backtrace_list;
+ LISP_INLINE Lisp_Object specpdl_where (struct specbinding *pdl)
+ { eassert (pdl->kind > SPECPDL_LET); return pdl->v.let.where; }
+
+ LISP_INLINE Lisp_Object specpdl_arg (struct specbinding *pdl)
+ { eassert (pdl->kind == SPECPDL_UNWIND); return pdl->v.unwind.arg; }
+
+ LISP_INLINE specbinding_func specpdl_func (struct specbinding *pdl)
+ { eassert (pdl->kind == SPECPDL_UNWIND); return pdl->v.unwind.func; }
+
+ LISP_INLINE Lisp_Object backtrace_function (struct specbinding *pdl)
+ { eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.function; }
+
+ LISP_INLINE ptrdiff_t backtrace_nargs (struct specbinding *pdl)
+ { eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.nargs; }
+
+ LISP_INLINE Lisp_Object *backtrace_args (struct specbinding *pdl)
+ { eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.args; }
+
+ LISP_INLINE bool backtrace_debug_on_exit (struct specbinding *pdl)
+ { eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.debug_on_exit; }
+
-extern struct specbinding *specpdl;
-extern struct specbinding *specpdl_ptr;
-extern ptrdiff_t specpdl_size;
++/* extern struct specbinding *specpdl; */
++/* extern struct specbinding *specpdl_ptr; */
++/* extern ptrdiff_t specpdl_size; */
+
+ #define SPECPDL_INDEX() (specpdl_ptr - specpdl)
/* Everything needed to describe an active condition case.
Lisp_Object tag;
Lisp_Object volatile val;
struct catchtag *volatile next;
+ #if 1 /* GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS, but they're defined later. */
struct gcpro *gcpro;
+ #endif
sys_jmp_buf jmp;
- struct backtrace *backlist;
- 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;
extern Lisp_Object safe_call2 (Lisp_Object, Lisp_Object, Lisp_Object);
extern void init_eval (void);
extern void syms_of_eval (void);
-extern void mark_specpdl (void);
+ extern void record_in_backtrace (Lisp_Object function,
+ Lisp_Object *args, ptrdiff_t nargs);
++extern void mark_specpdl (struct specbinding *first, struct 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);
(STRINGP (host) ? host : build_string ("-")),
build_string ("\n")));
- if (!NILP (p->sentinel))
- exec_sentinel (proc,
- concat3 (build_string ("open from "),
- (STRINGP (host) ? host : build_string ("-")),
- build_string ("\n")));
+ exec_sentinel (proc,
+ concat3 (build_string ("open from "),
+ (STRINGP (host) ? host : build_string ("-")),
+ 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)
{
if (! noninteractive || initialized)
#endif
{
- struct sigaction action;
- emacs_sigaction_init (&action, deliver_child_signal);
- sigaction (SIGCHLD, &action, 0);
+ 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
extern void delete_read_fd (int fd);
extern void add_write_fd (int fd, fd_callback func, void *data);
extern void delete_write_fd (int fd);
+ extern void catch_child_signal (void);
+extern void update_processes_for_thread_death (Lisp_Object);
+
INLINE_HEADER_END
--- /dev/null
- Copyright (C) 2012 Free Software Foundation, Inc.
+/* Threading code.
- struct specbinding *bind;
++ 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;
+
+\f
+
+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)
+ {
+ 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);
+}
+
+\f
+
+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;
+}
+
+\f
+
+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);
+}
+
+\f
+
+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);
+ current_thread->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);
+ current_thread->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);
+}
+
+\f
+
+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;
+}
+
+\f
+
+static void
+mark_one_thread (struct thread_state *thread)
+{
- for (bind = thread->m_specpdl; bind != thread->m_specpdl_ptr; bind++)
- {
- mark_object (bind->symbol);
- mark_object (bind->old_value);
- mark_object (bind->saved_value);
- }
+ struct handler *handler;
+ Lisp_Object tem;
+
-
- mark_backtrace (thread->m_backtrace_list);
++ 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);
+}
+
+\f
+
+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;
+
+ 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 = self->m_stack_bottom = &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);
+
+ unbind_for_thread_switch ();
+
+ update_processes_for_thread_death (Fcurrent_thread ());
+
+ /* Unlink this thread from the list of all threads. */
+ for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
+ ;
+ *iter = (*iter)->next_thread;
+
+ self->m_last_thing_searched = Qnil;
+ self->m_saved_last_thing_searched = Qnil;
+ self->name = Qnil;
+ self->function = Qnil;
+ self->error_symbol = Qnil;
+ self->error_data = Qnil;
+ xfree (self->m_specpdl);
+ self->m_specpdl = NULL;
+ self->m_specpdl_ptr = NULL;
+ self->m_specpdl_size = 0;
+
+ sys_cond_broadcast (&self->thread_condvar);
+
+ 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 (new_thread->m_specpdl_size
+ * sizeof (struct specbinding));
+ 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);
+
+ /* m_specpdl is set when the thread is created and cleared when the
+ thread dies. */
+ return tstate->m_specpdl == NULL ? Qnil : Qt;
+}
+
+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 (tstate->m_specpdl != NULL && 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 (tstate->m_specpdl != NULL)
+ 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)
+ {
+ Lisp_Object thread;
+
+ XSETTHREAD (thread, iter);
+ result = Fcons (thread, result);
+ }
+
+ return result;
+}
+
+\f
+
+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;
+}
+
+\f
+
+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;
+
+ sys_cond_init (&primary_thread.thread_condvar);
+}
+
+void
+init_threads_once (void)
+{
+ init_primary_thread ();
+}
+
+void
+init_threads (void)
+{
+ init_primary_thread ();
+
+ sys_mutex_init (&global_lock);
+ sys_mutex_lock (&global_lock);
+}
+
+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);
+}
--- /dev/null
- struct backtrace *m_backtrace_list;
- #define backtrace_list (current_thread->m_backtrace_list)
-
+/* 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. */
+ struct specbinding *m_specpdl;
+#define specpdl (current_thread->m_specpdl)
+
+ /* Pointer to first unused element in specpdl. */
+ struct specbinding *m_specpdl_ptr;
+#define specpdl_ptr (current_thread->m_specpdl_ptr)
+
+ /* Pointer to the first "saved" element in specpdl. When this
+ thread is swapped out, the current values of all specpdl bindings
+ are pushed onto the specpdl; then these are popped again when
+ switching back to this thread. */
+ struct specbinding *m_saved_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 */
projects / emacs.git / commitdiff