From 51100bb8d36f68842ab55fd0501af56dfc58cc51 Mon Sep 17 00:00:00 2001 From: Tom Tromey Date: Wed, 15 Aug 2012 13:11:22 -0600 Subject: [PATCH] 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 69742a325d1..80d22d61d66 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3104,6 +3104,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 fd2194fe1ae..b47c2d12aff 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; +} /* Extract and set components of lists */ @@ -3105,6 +3116,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"); @@ -3148,6 +3160,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 52a523259db..f0c831852f6 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -366,6 +366,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 @@ -555,6 +556,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. */ @@ -606,6 +608,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. */ @@ -1705,6 +1708,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)) @@ -1826,6 +1830,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) \ @@ -2448,7 +2455,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 4537521b9fa..42e7241ecba 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 ("#'); + } else { ptrdiff_t size = ASIZE (obj); diff --git a/src/thread.c b/src/thread.c index 5da2e10f1ae..80557e5d5ee 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; + + + +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); +} @@ -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 3b533316817..d3ec38a22b9 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); -- 2.39.5