From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Tom Tromey Newsgroups: gmane.emacs.devel Subject: [PATCH 06/10] add most lisp-level features Date: Thu, 09 Aug 2012 13:41:55 -0600 Message-ID: <87a9y3etto.fsf@fleche.redhat.com> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: dough.gmane.org 1344541331 13425 80.91.229.3 (9 Aug 2012 19:42:11 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Thu, 9 Aug 2012 19:42:11 +0000 (UTC) To: Emacs discussions Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Thu Aug 09 21:42:12 2012 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1SzYcQ-0001T6-UG for ged-emacs-devel@m.gmane.org; Thu, 09 Aug 2012 21:42:07 +0200 Original-Received: from localhost ([::1]:49461 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1SzYcQ-0002lY-3N for ged-emacs-devel@m.gmane.org; Thu, 09 Aug 2012 15:42:06 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:46891) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1SzYcM-0002lL-SW for emacs-devel@gnu.org; Thu, 09 Aug 2012 15:42:04 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1SzYcK-0005I2-3f for emacs-devel@gnu.org; Thu, 09 Aug 2012 15:42:02 -0400 Original-Received: from mx1.redhat.com ([209.132.183.28]:32358) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1SzYcJ-0005Hv-Qc for emacs-devel@gnu.org; Thu, 09 Aug 2012 15:42:00 -0400 Original-Received: from int-mx10.intmail.prod.int.phx2.redhat.com (int-mx10.intmail.prod.int.phx2.redhat.com [10.5.11.23]) by mx1.redhat.com (8.14.4/8.14.4) with ESMTP id q79Jfw9e016811 (version=TLSv1/SSLv3 cipher=DHE-RSA-AES256-SHA bits=256 verify=OK) for ; Thu, 9 Aug 2012 15:41:59 -0400 Original-Received: from barimba (ovpn01.gateway.prod.ext.phx2.redhat.com [10.5.9.1]) by int-mx10.intmail.prod.int.phx2.redhat.com (8.14.4/8.14.4) with ESMTP id q79JftLF013079 (version=TLSv1/SSLv3 cipher=DHE-RSA-AES128-SHA bits=128 verify=NO); Thu, 9 Aug 2012 15:41:56 -0400 X-Attribution: Tom User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.1 (gnu/linux) X-Scanned-By: MIMEDefang 2.68 on 10.5.11.23 X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-Received-From: 209.132.183.28 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:152380 Archived-At: This adds most of the thread features visible to emacs lisp. I roughly followed the Bordeaux threads API: http://trac.common-lisp.net/bordeaux-threads/wiki/ApiDocumentation ... but not identically. In particular I chose not to implement interrupt-thread or destroy-thread, but instead a thread-signalling approach. I'm still undecided about *default-special-bindings* (which I did not implement). I think it would be more emacs-like to capture the let bindings at make-thread time, but IIRC Stefan didn't like this idea the first time around. There are one or two semantics issues pointed out in the patch where I could use some advice. I see a couple of bits that should probably be in the previous patch. Sorry about that. --- src/alloc.c | 3 + src/data.c | 15 +++ src/emacs.c | 2 + src/lisp.h | 5 + src/systhread.c | 15 +-- src/thread.c | 354 +++++++++++++++++++++++++++++++++++++++++++++++++++++-- src/thread.h | 25 ++++ 7 files changed, 400 insertions(+), 19 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index b3dab59..d114202 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3094,6 +3094,9 @@ sweep_vectors (void) ptrdiff_t nbytes = PSEUDOVECTOR_NBYTES (vector); ptrdiff_t total_bytes = nbytes; + if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD)) + finalize_one_thread ((struct thread_state *) vector); + next = ADVANCE (vector, nbytes); /* While NEXT is not marked, try to coalesce with VECTOR, diff --git a/src/data.c b/src/data.c index c4519fc..162c46e 100644 --- a/src/data.c +++ b/src/data.c @@ -94,6 +94,7 @@ static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; static Lisp_Object Qsubrp, Qmany, Qunevalled; Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; static Lisp_Object Qdefun; +Lisp_Object Qthread; Lisp_Object Qinteractive_form; @@ -211,6 +212,8 @@ for example, (type-of 1) returns `integer'. */) return Qfont_entity; if (FONT_OBJECT_P (object)) return Qfont_object; + if (THREADP (object)) + return Qthread; return Qvector; case Lisp_Float: @@ -458,6 +461,16 @@ 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; +} + /* Extract and set components of lists */ @@ -3089,6 +3102,7 @@ syms_of_data (void) DEFSYM (Qchar_table, "char-table"); DEFSYM (Qbool_vector, "bool-vector"); DEFSYM (Qhash_table, "hash-table"); + DEFSYM (Qthread, "thread"); /* Used by Fgarbage_collect. */ DEFSYM (Qinterval, "interval"); DEFSYM (Qmisc, "misc"); @@ -3131,6 +3145,7 @@ syms_of_data (void) defsubr (&Ssubrp); defsubr (&Sbyte_code_function_p); defsubr (&Schar_or_string_p); + defsubr (&Sthreadp); defsubr (&Scar); defsubr (&Scdr); defsubr (&Scar_safe); diff --git a/src/emacs.c b/src/emacs.c index ca9f201..9255252 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1552,6 +1552,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_ntterm (); #endif /* WINDOWSNT */ + syms_of_threads (); + keys_of_casefiddle (); keys_of_cmds (); keys_of_buffer (); diff --git a/src/lisp.h b/src/lisp.h index 7d0a3dc..c00b775 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -553,6 +553,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) #define XBOOL_VECTOR(a) (eassert (BOOL_VECTOR_P (a)), \ ((struct Lisp_Bool_Vector *) \ XUNTAG (a, Lisp_Vectorlike))) +#define XTHREAD(a) (eassert (THREADP (a)), (struct thread_state *) XPNTR(a)) /* Construct a Lisp_Object from a value or address. */ @@ -1821,6 +1822,9 @@ typedef struct { #define CHECK_OVERLAY(x) \ CHECK_TYPE (OVERLAYP (x), Qoverlayp, x) +#define CHECK_THREAD(x) \ + CHECK_TYPE (THREADP (x), Qthreadp, 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. */ #define CHECK_NUMBER_CAR(x) \ @@ -2443,6 +2447,7 @@ extern Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp; extern Lisp_Object Qbuffer_or_string_p; extern Lisp_Object Qfboundp; extern Lisp_Object Qchar_table_p, Qvector_or_char_table_p; +extern Lisp_Object Qthreadp; extern Lisp_Object Qcdr; diff --git a/src/systhread.c b/src/systhread.c index d5f00ba..e6a9199 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -105,19 +105,12 @@ lisp_mutex_lock (lisp_mutex_t *mutex) } self = current_thread; - while (mutex->owner != NULL /* && EQ (self->error_symbol, Qnil) */) + self->wait_condvar = &mutex->condition; + while (mutex->owner != NULL && EQ (self->error_symbol, Qnil)) pthread_cond_wait (&mutex->condition, &global_lock); + self->wait_condvar = NULL; -#if 0 - if (!EQ (self->error_symbol, Qnil)) - { - Lisp_Object error_symbol = self->error_symbol; - Lisp_Object data = self->error_data; - self->error_symbol = Qnil; - self->error_data = Qnil; - Fsignal (error_symbol, error_data); - } -#endif + post_acquire_global_lock (self); mutex->owner = self; mutex->count = 1; diff --git a/src/thread.c b/src/thread.c index 7d2f81e..5da2e10 100644 --- a/src/thread.c +++ b/src/thread.c @@ -20,15 +20,70 @@ along with GNU Emacs. If not, see . */ #include #include #include "lisp.h" +#include "character.h" +#include "buffer.h" -struct thread_state the_only_thread; +/* FIXME */ +extern void unbind_for_thread_switch (void); +extern void rebind_for_thread_switch (void); -struct thread_state *current_thread = &the_only_thread; +static struct thread_state primary_thread; -struct thread_state *all_threads = &the_only_thread; +struct thread_state *current_thread = &primary_thread; + +static struct thread_state *all_threads = &primary_thread; sys_mutex_t global_lock; +Lisp_Object Qthreadp; + + + +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. */ +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 (!EQ (current_thread->error_symbol, Qnil)) + { + 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 mark_one_thread (struct thread_state *thread) { @@ -113,19 +168,302 @@ unmark_threads (void) 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; + + 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 (); + + /* 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 -init_threads_once (void) +finalize_one_thread (struct thread_state *state) { - the_only_thread.header.size + 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; + + /* Can't start a thread in temacs. */ + if (!initialized) + abort (); + + 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->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 (! sys_thread_create (&thr, 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: /* FIXME */) + (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: /* FIXME */) + (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; +} + +static void +thread_join_callback (void *arg) +{ + struct thread_state *tstate = arg; + struct thread_state *self = current_thread; + + self->wait_condvar = &tstate->thread_condvar; + while (tstate->m_specpdl != NULL && EQ (self->error_symbol, Qnil)) + sys_cond_wait (self->wait_condvar, &global_lock); + + self->wait_condvar = NULL; + post_acquire_global_lock (self); +} + +DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0, + doc: /* FIXME */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (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; +} + + + +static void +init_primary_thread (void) +{ + primary_thread.header.size = PSEUDOVECSIZE (struct thread_state, m_gcprolist); - XSETPVECTYPE (&the_only_thread, PVEC_THREAD); - the_only_thread.m_last_thing_searched = Qnil; - the_only_thread.m_saved_last_thing_searched = Qnil; + 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; + + 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 (&Sall_threads); + + Qthreadp = intern_c_string ("threadp"); + staticpro (&Qthreadp); +} diff --git a/src/thread.h b/src/thread.h index df26b88..3b53331 100644 --- a/src/thread.h +++ b/src/thread.h @@ -34,6 +34,16 @@ struct thread_state 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; + /* m_gcprolist must be the first non-lisp field. */ /* Recording what needs to be marked for gc. */ struct gcpro *m_gcprolist; @@ -142,6 +152,18 @@ struct thread_state /*re_char*/ unsigned char *m_whitespace_regexp; #define whitespace_regexp (current_thread->m_whitespace_regexp) + /* 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; }; @@ -149,10 +171,13 @@ struct thread_state extern struct thread_state *current_thread; extern sys_mutex_t global_lock; +extern void post_acquire_global_lock (struct thread_state *); extern void unmark_threads (void); +extern void finalize_one_thread (struct thread_state *state); extern void init_threads_once (void); extern void init_threads (void); +extern void syms_of_threads (void); #endif /* THREAD_H */ -- 1.7.7.6