From: Tom Tromey <tromey@redhat.com>
To: Emacs discussions <emacs-devel@gnu.org>
Subject: [PATCH 07/10] mutex implementation
Date: Thu, 09 Aug 2012 13:42:37 -0600 [thread overview]
Message-ID: <87628retsi.fsf@fleche.redhat.com> (raw)
This supplies the mutex implementation for Emacs Lisp.
A lisp mutex is implemented using a condition variable, so that we can
interrupt a mutex-lock operation by calling thread-signal on the
blocking thread. I did things this way because pthread_mutex_lock
can't readily be interrupted.
---
src/alloc.c | 2 +
src/data.c | 15 ++++++++++-
src/lisp.h | 9 +++++-
src/print.c | 8 +++++
src/thread.c | 83 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
src/thread.h | 3 ++
6 files changed, 117 insertions(+), 3 deletions(-)
diff --git a/src/alloc.c b/src/alloc.c
index d114202..67a0d2f 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3096,6 +3096,8 @@ sweep_vectors (void)
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);
next = ADVANCE (vector, nbytes);
diff --git a/src/data.c b/src/data.c
index 162c46e..b3768a3 100644
--- a/src/data.c
+++ b/src/data.c
@@ -94,7 +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 Qthread, Qmutex;
Lisp_Object Qinteractive_form;
@@ -214,6 +214,8 @@ for example, (type-of 1) returns `integer'. */)
return Qfont_object;
if (THREADP (object))
return Qthread;
+ if (MUTEXP (object))
+ return Qmutex;
return Qvector;
case Lisp_Float:
@@ -471,6 +473,15 @@ DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0,
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;
+}
\f
/* Extract and set components of lists */
@@ -3103,6 +3114,7 @@ syms_of_data (void)
DEFSYM (Qbool_vector, "bool-vector");
DEFSYM (Qhash_table, "hash-table");
DEFSYM (Qthread, "thread");
+ DEFSYM (Qmutex, "mutex");
/* Used by Fgarbage_collect. */
DEFSYM (Qinterval, "interval");
DEFSYM (Qmisc, "misc");
@@ -3146,6 +3158,7 @@ syms_of_data (void)
defsubr (&Sbyte_code_function_p);
defsubr (&Schar_or_string_p);
defsubr (&Sthreadp);
+ defsubr (&Smutexp);
defsubr (&Scar);
defsubr (&Scdr);
defsubr (&Scar_safe);
diff --git a/src/lisp.h b/src/lisp.h
index c00b775..7aef74f 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -365,6 +365,7 @@ enum pvec_type
PVEC_SUBR,
PVEC_OTHER,
PVEC_THREAD,
+ PVEC_MUTEX,
/* These last 4 are special because we OR them in fns.c:internal_equal,
so they have to use a disjoint bit pattern:
if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE
@@ -554,6 +555,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper)
((struct Lisp_Bool_Vector *) \
XUNTAG (a, Lisp_Vectorlike)))
#define XTHREAD(a) (eassert (THREADP (a)), (struct thread_state *) XPNTR(a))
+#define XMUTEX(a) (eassert (MUTEXP (a)), (struct Lisp_Mutex *) XPNTR(a))
/* Construct a Lisp_Object from a value or address. */
@@ -605,6 +607,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper)
#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))
/* Convenience macros for dealing with Lisp arrays. */
@@ -1704,6 +1707,7 @@ typedef struct {
#define BOOL_VECTOR_P(x) PSEUDOVECTORP (x, PVEC_BOOL_VECTOR)
#define FRAMEP(x) PSEUDOVECTORP (x, PVEC_FRAME)
#define THREADP(x) PSEUDOVECTORP (x, PVEC_THREAD)
+#define MUTEXP(x) PSEUDOVECTORP (x, PVEC_MUTEX)
/* Test for image (image . spec) */
#define IMAGEP(x) (CONSP (x) && EQ (XCAR (x), Qimage))
@@ -1825,6 +1829,9 @@ typedef struct {
#define CHECK_THREAD(x) \
CHECK_TYPE (THREADP (x), Qthreadp, x)
+#define CHECK_MUTEX(x) \
+ CHECK_TYPE (MUTEXP (x), Qmutexp, 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) \
@@ -2447,7 +2454,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 Qthreadp, Qmutexp;
extern Lisp_Object Qcdr;
diff --git a/src/print.c b/src/print.c
index d879239..ce917bc 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1955,6 +1955,14 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag
}
PRINTCHAR ('>');
}
+ else if (MUTEXP (obj))
+ {
+ int len;
+ strout ("#<mutex ", -1, -1, printcharfun);
+ len = sprintf (buf, "%p", XMUTEX (obj));
+ strout (buf, len, len, printcharfun);
+ PRINTCHAR ('>');
+ }
else
{
ptrdiff_t size = ASIZE (obj);
diff --git a/src/thread.c b/src/thread.c
index 5da2e10..80557e5 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -35,7 +35,83 @@ static struct thread_state *all_threads = &primary_thread;
sys_mutex_t global_lock;
-Lisp_Object Qthreadp;
+Lisp_Object Qthreadp, Qmutexp;
+
+\f
+
+struct Lisp_Mutex
+{
+ struct vectorlike_header header;
+
+ lisp_mutex_t mutex;
+};
+
+DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 0, 0,
+ doc: /* FIXME */)
+ (void)
+{
+ struct Lisp_Mutex *mutex;
+ Lisp_Object result;
+
+ 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));
+ lisp_mutex_init (&mutex->mutex);
+
+ XSETMUTEX (result, mutex);
+ return result;
+}
+
+static void
+mutex_lock_callback (void *arg)
+{
+ struct Lisp_Mutex *mutex = arg;
+
+ /* This calls post_acquire_global_lock. */
+ lisp_mutex_lock (&mutex->mutex);
+}
+
+DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
+ doc: /* FIXME */)
+ (Lisp_Object obj)
+{
+ struct Lisp_Mutex *mutex;
+
+ CHECK_MUTEX (obj);
+ mutex = XMUTEX (obj);
+
+ flush_stack_call_func (mutex_lock_callback, mutex);
+ return Qnil;
+}
+
+static void
+mutex_unlock_callback (void *arg)
+{
+ struct Lisp_Mutex *mutex = arg;
+
+ /* This calls post_acquire_global_lock. */
+ lisp_mutex_unlock (&mutex->mutex);
+}
+
+DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
+ doc: /* FIXME */)
+ (Lisp_Object obj)
+{
+ struct Lisp_Mutex *mutex;
+
+ CHECK_MUTEX (obj);
+ mutex = XMUTEX (obj);
+
+ flush_stack_call_func (mutex_unlock_callback, mutex);
+ return Qnil;
+}
+
+void
+finalize_one_mutex (struct Lisp_Mutex *mutex)
+{
+ lisp_mutex_destroy (&mutex->mutex);
+}
\f
@@ -463,7 +539,12 @@ syms_of_threads (void)
defsubr (&Sthread_alive_p);
defsubr (&Sthread_join);
defsubr (&Sall_threads);
+ defsubr (&Smake_mutex);
+ defsubr (&Smutex_lock);
+ defsubr (&Smutex_unlock);
Qthreadp = intern_c_string ("threadp");
staticpro (&Qthreadp);
+ Qmutexp = intern_c_string ("mutexp");
+ staticpro (&Qmutexp);
}
diff --git a/src/thread.h b/src/thread.h
index 3b53331..d3ec38a 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -168,6 +168,8 @@ struct thread_state
struct thread_state *next_thread;
};
+struct Lisp_Mutex;
+
extern struct thread_state *current_thread;
extern sys_mutex_t global_lock;
@@ -175,6 +177,7 @@ 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 finalize_one_mutex (struct Lisp_Mutex *);
extern void init_threads_once (void);
extern void init_threads (void);
--
1.7.7.6
reply other threads:[~2012-08-09 19:42 UTC|newest]
Thread overview: [no followups] expand[flat|nested] mbox.gz Atom feed
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87628retsi.fsf@fleche.redhat.com \
--to=tromey@redhat.com \
--cc=emacs-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.