commit 7ca9b7adb656acb42a3db4b0fb33b020afa1e201
parent f1ed54d9fa77c9378fc035dda595646e43f0535d
Author: Andres Navarro <canavarro82@gmail.com>
Date: Thu, 30 Aug 2012 00:07:44 -0300
Added contition variables objects and ground combiners (condition-variable?, make-condition-variable, condition-variable-wait, condition-variable-signal, condition-variable-broadcast).
Diffstat:
9 files changed, 243 insertions(+), 8 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -57,6 +57,7 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kgencapsulations.o kgpromises.o kgkd_vars.o kgks_vars.o kgports.o \
kgchars.o kgnumbers.o kgstrings.o kgbytevectors.o kgvectors.o \
kgtables.o kgsystem.o kgerrors.o kgkeywords.o kgthreads.o kmutex.o \
+ kcondvar.o \
$(if $(USE_LIBFFI),kgffi.o)
# TEMP: in klisp there is no distinction between core & lib
@@ -147,6 +148,8 @@ kauxlib.o: kauxlib.c klisp.h kstate.h klimits.h kobject.h klispconf.h \
kbytevector.o: kbytevector.c kbytevector.h kobject.h klimits.h klisp.h \
klispconf.h kstate.h ktoken.h kmem.h kgc.h kstring.h
kchar.o: kchar.c kobject.h klimits.h klisp.h klispconf.h
+kcondvar.o: kcondvar.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
+ ktoken.h kmem.h kmutex.h kcondvar.h kgc.h kerror.h kpair.h
kcontinuation.o: kcontinuation.c kcontinuation.h kobject.h klimits.h \
klisp.h klispconf.h kstate.h ktoken.h kmem.h kpair.h kgc.h \
kapplicative.h koperative.h
@@ -171,7 +174,7 @@ kgbytevectors.o: kgbytevectors.c kstate.h klimits.h klisp.h kobject.h \
kenvironment.h ksymbol.h kstring.h ktable.h kgbytevectors.h
kgc.o: kgc.c kgc.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kport.h imath.h imrat.h ktable.h kstring.h kbytevector.h \
- kvector.h kerror.h kpair.h kmutex.h
+ kvector.h kmutex.h kcondvar.h kerror.h kpair.h
kgchars.o: kgchars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
kpair.h kgc.h kchar.h kghelpers.h kvector.h kenvironment.h ksymbol.h \
@@ -284,9 +287,9 @@ kgtables.o: kgtables.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kpair.h kgc.h kghelpers.h kvector.h kenvironment.h ksymbol.h kstring.h \
ktable.h kgtables.h
kgthreads.o: kgthreads.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kmutex.h kghelpers.h kerror.h kpair.h kgc.h kvector.h \
- kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
- kstring.h ktable.h
+ ktoken.h kmem.h kmutex.h kcondvar.h kghelpers.h kerror.h kpair.h kgc.h \
+ kvector.h kapplicative.h koperative.h kcontinuation.h kenvironment.h \
+ ksymbol.h kstring.h ktable.h
kgvectors.o: kgvectors.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
kpair.h kgc.h kvector.h kbytevector.h kghelpers.h kenvironment.h \
diff --git a/src/kcondvar.c b/src/kcondvar.c
@@ -0,0 +1,107 @@
+/*
+** kcondvar.c
+** Kernel Libraries
+** See Copyright Notice in klisp.h
+*/
+
+#include "kobject.h"
+#include "kstate.h"
+#include "kmutex.h"
+#include "kcondvar.h"
+#include "kmem.h"
+#include "kgc.h"
+#include "kerror.h"
+
+/* GC: Assumes mutex is rooted */
+TValue kmake_condvar(klisp_State *K, TValue mutex)
+{
+ Condvar *new_condvar = klispM_new(K, Condvar);
+
+ /* header + gc_fields */
+ klispC_link(K, (GCObject *) new_condvar, K_TCONDVAR, 0);
+
+ /* condvar specific fields */
+ new_condvar->mutex = mutex;
+
+ /* XXX no attrs for now */
+ int32_t res = pthread_cond_init(&new_condvar->cond, NULL);
+
+ if (res != 0) {
+ klispE_throw_simple_with_irritants(K, "Can't create conndition "
+ "variable", 1, i2tv(res));
+ return KNIL;
+ }
+ return gc2condvar(new_condvar);
+}
+
+/* LOCK: GIL should be acquired exactly once */
+/* LOCK: underlying mutex should be acquired by this thread */
+/* GC: condvar should be rooted */
+void kcondvar_wait(klisp_State *K, TValue condvar)
+{
+ TValue thread = gc2th(K);
+ TValue mutex = kcondvar_mutex(condvar);
+
+ if (!tv_equal(thread, kmutex_owner(mutex))) {
+ klispE_throw_simple(K, "Can't wait without holding the mutex");
+ return;
+ }
+
+ /* save mutex info to recover after awakening */
+ uint32_t count = kmutex_count(mutex);
+ kmutex_owner(mutex) = KMUTEX_NO_OWNER;
+ kmutex_count(mutex) = 0;
+
+ /* we need to release GIL to avoid deadlocks */
+ klisp_unlock(K);
+ int res = pthread_cond_wait(&kcondvar_cond(condvar),
+ &kmutex_mutex(mutex));
+ klisp_lock(K);
+
+ /* recover the saved mutex info */
+ klisp_assert(!kmutex_is_owned(mutex));
+
+ kmutex_owner(mutex) = thread;
+ kmutex_count(mutex) = count;
+
+ /* This shouldn't happen, according to the spec */
+ if (res != 0) {
+ klispE_throw_simple_with_irritants(K, "Couldn't wait on condvar",
+ 1, i2tv(res));
+ return;
+ }
+}
+
+/* LOCK: GIL should be acquired exactly once */
+/* LOCK: underlying mutex should be acquired by this thread */
+/* GC: condvar should be rooted */
+void kcondvar_signal(klisp_State *K, TValue condvar, bool broadcast)
+{
+ TValue thread = gc2th(K);
+ TValue mutex = kcondvar_mutex(condvar);
+
+ if (!tv_equal(thread, kmutex_owner(mutex))) {
+ klispE_throw_simple(K, broadcast?
+ "Can't broadcast without holding the mutex" :
+ "Can't signal without holding the mutex");
+ return;
+ }
+
+ int res = broadcast? pthread_cond_broadcast(&kcondvar_cond(condvar)) :
+ pthread_cond_signal(&kcondvar_cond(condvar));
+
+ /* This shouldn't happen, according to the spec */
+ if (res != 0) {
+ klispE_throw_simple_with_irritants(K, broadcast?
+ "Couldn't broadcast on condvar" :
+ "Couldn't signal on condvar",
+ 1, i2tv(res));
+ return;
+ }
+}
+
+void klispV_free(klisp_State *K, Condvar *m)
+{
+ UNUSED(pthread_cond_destroy(&m->cond));
+ klispM_free(K, m);
+}
diff --git a/src/kcondvar.h b/src/kcondvar.h
@@ -0,0 +1,27 @@
+/*
+** kcondvar.h
+** Kernel Libraries
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kcondvar_h
+#define kcondvar_h
+
+#include "kobject.h"
+#include "kstate.h"
+
+TValue kmake_condvar(klisp_State *K, TValue mutex);
+void klispV_free(klisp_State *K, Condvar *condvar);
+
+/* LOCK: these functions require that the calling code has
+ acquired the GIL exactly once previous to the call and
+ they may temporarily release it to avoid deadlocks */
+/* LOCK: underlying mutex should be acquired by this thread */
+/* GC: condvar should be rooted */
+void kcondvar_wait(klisp_State *K, TValue condvar);
+void kcondvar_signal(klisp_State *K, TValue condvar, bool broadcast);
+
+#define kcondvar_mutex(c_) (tv2condvar(c_)->mutex)
+#define kcondvar_cond(m_) (tv2condvar(m_)->cond)
+
+#endif
diff --git a/src/kgc.c b/src/kgc.c
@@ -28,6 +28,7 @@
#include "kbytevector.h"
#include "kvector.h"
#include "kmutex.h"
+#include "kcondvar.h"
#include "kerror.h"
#define GCSTEPSIZE 1024u
@@ -123,6 +124,7 @@ static void reallymarkobject (global_State *g, GCObject *o)
case K_TLIBRARY:
case K_TTHREAD:
case K_TMUTEX:
+ case K_TCONDVAR:
o->gch.gclist = g->gray;
g->gray = o;
break;
@@ -393,6 +395,12 @@ static int32_t propagatemark (global_State *g) {
markvalue(g, m->owner);
return sizeof(Mutex);
}
+ case K_TCONDVAR: {
+ Condvar *c = cast(Condvar *, o);
+
+ markvalue(g, c->mutex);
+ return sizeof(Condvar);
+ }
default:
fprintf(stderr, "Unknown GCObject type (in GC propagate): %d\n",
type);
@@ -559,7 +567,10 @@ static void freeobj (klisp_State *K, GCObject *o) {
break;
}
case K_TMUTEX:
- klispX_free(K, (Mutex *)o);
+ klispX_free(K, (Mutex *) o);
+ break;
+ case K_TCONDVAR:
+ klispV_free(K, (Condvar *) o);
break;
default:
/* shouldn't happen */
diff --git a/src/kgthreads.c b/src/kgthreads.c
@@ -12,6 +12,7 @@
#include "kstate.h"
#include "kobject.h"
#include "kmutex.h"
+#include "kcondvar.h"
#include "kghelpers.h"
/* ?.1? thread? */
@@ -213,6 +214,54 @@ static void mutex_trylock(klisp_State *K)
kapply_cc(K, b2tv(res));
}
+/* make-mutex */
+static void make_condvar(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "mutex", ttismutex, mutex);
+
+ TValue new_condvar = kmake_condvar(K, mutex);
+ kapply_cc(K, new_condvar);
+}
+
+/* condition-variable-wait */
+static void condvar_wait(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "condition-variable", ttiscondvar, condvar);
+ kcondvar_wait(K, condvar);
+ kapply_cc(K, KINERT);
+}
+
+/* condition-variable-signal / condition-variable-broadcast */
+static void condvar_signal(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(denv);
+ /*
+ ** xparams[0]: broadcast?
+ */
+ bool broadcast = bvalue(xparams[0]);
+
+ bind_1tp(K, ptree, "condition-variable", ttiscondvar, condvar);
+ kcondvar_signal(K, condvar, broadcast);
+ kapply_cc(K, KINERT);
+}
/* init ground */
void kinit_threads_ground_env(klisp_State *K)
@@ -243,11 +292,30 @@ void kinit_threads_ground_env(klisp_State *K)
/* make-mutex */
add_applicative(K, ground_env, "make-mutex", make_mutex, 0);
/* REFACTOR: should lock and unlock have an '!'?
- What about try lock?? '!', '?', '!?', neither?
+ What about try lock?? '!', '?', '!?', neither? */
/* mutex-lock */
add_applicative(K, ground_env, "mutex-lock", mutex_lock, 0);
/* mutex-unlock */
add_applicative(K, ground_env, "mutex-unlock", mutex_unlock, 0);
/* mutex-trylock */
add_applicative(K, ground_env, "mutex-trylock", mutex_trylock, 0);
+
+ /* Condition variables */
+ /* condition-variable? */
+ add_applicative(K, ground_env, "condition-variable?", typep, 2, symbol,
+ i2tv(K_TCONDVAR));
+
+ /* make-condition-variable */
+ add_applicative(K, ground_env, "make-condition-variable",
+ make_condvar, 0);
+ /* REFACTOR: should signal have an '!'? */
+ /* condition-variable-wait */
+ add_applicative(K, ground_env, "condition-variable-wait",
+ condvar_wait, 0);
+ /* condition-variable-signal */
+ add_applicative(K, ground_env, "condition-variable-signal",
+ condvar_signal, 1, b2tv(false));
+ /* condition-variable-broadcast */
+ add_applicative(K, ground_env, "condition-variable-broadcast",
+ condvar_signal, 1, b2tv(true));
}
diff --git a/src/kmutex.c b/src/kmutex.c
@@ -11,8 +11,6 @@
#include "kgc.h"
#include "kerror.h"
-/* GC: Assumes env & ext_list are roooted */
-/* ext_list should be immutable (and it may be empty) */
TValue kmake_mutex(klisp_State *K)
{
Mutex *new_mutex = klispM_new(K, Mutex);
diff --git a/src/kmutex.h b/src/kmutex.h
@@ -16,6 +16,7 @@ void klispX_free(klisp_State *K, Mutex *mutex);
/* LOCK: these functions require that the calling code has
acquired the GIL exactly once previous to the call and
they may temporarily release it to avoid deadlocks */
+/* All of these do the required checks of owernship */
void kmutex_lock(klisp_State *K, TValue mutex);
void kmutex_unlock(klisp_State *K, TValue mutex);
bool kmutex_trylock(klisp_State *K, TValue mutex);
diff --git a/src/kobject.h b/src/kobject.h
@@ -174,6 +174,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TLIBRARY 46
#define K_TTHREAD 47
#define K_TMUTEX 48
+#define K_TCONDVAR 49
/* for tables */
#define K_TDEADKEY 60
@@ -233,6 +234,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TAG_LIBRARY K_MAKE_VTAG(K_TLIBRARY)
#define K_TAG_THREAD K_MAKE_VTAG(K_TTHREAD)
#define K_TAG_MUTEX K_MAKE_VTAG(K_TMUTEX)
+#define K_TAG_CONDVAR K_MAKE_VTAG(K_TCONDVAR)
/*
** Macros to test types
@@ -337,6 +339,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttislibrary(o) (tbasetype_(o) == K_TAG_LIBRARY)
#define ttisthread(o) (tbasetype_(o) == K_TAG_THREAD)
#define ttismutex(o) (tbasetype_(o) == K_TAG_MUTEX)
+#define ttiscondvar(o) (tbasetype_(o) == K_TAG_CONDVAR)
/* macros to easily check boolean values */
#define kis_true(o_) (tv_equal((o_), KTRUE))
@@ -577,6 +580,12 @@ typedef struct __attribute__ ((__packed__)) {
uint32_t count; /* count for recursive mutex */
} Mutex;
+typedef struct __attribute__ ((__packed__)) {
+ CommonHeader; /* symbols are marked via their strings */
+ TValue mutex;
+ pthread_cond_t cond;
+} Condvar;
+
/*
** `module' operation for hashing (size is always a power of 2)
*/
@@ -732,6 +741,7 @@ const TValue kfree;
#define gc2lib(o_) (gc2tv(K_TAG_LIBRARY, o_))
#define gc2th(o_) (gc2tv(K_TAG_THREAD, o_))
#define gc2mutex(o_) (gc2tv(K_TAG_MUTEX, o_))
+#define gc2condvar(o_) (gc2tv(K_TAG_CONDVAR, o_))
#define gc2deadkey(o_) (gc2tv(K_TAG_DEADKEY, o_))
/* Macro to convert a TValue into a specific heap allocated object */
@@ -757,6 +767,7 @@ const TValue kfree;
#define tv2lib(v_) ((Library *) gcvalue(v_))
#define tv2th(v_) ((klisp_State *) gcvalue(v_))
#define tv2mutex(v_) ((Mutex *) gcvalue(v_))
+#define tv2condvar(v_) ((Condvar *) gcvalue(v_))
#define tv2gch(v_) ((GCheader *) gcvalue(v_))
#define tv2mgch(v_) ((MGCheader *) gcvalue(v_))
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -743,6 +743,15 @@ void kwrite_scalar(klisp_State *K, TValue obj)
#endif
kw_printf(K, "]");
break;
+ case K_TCONDVAR:
+ kw_printf(K, "#[condvar");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+ kw_printf(K, "]");
+ break;
default:
/* shouldn't happen */
kwrite_error(K, "unknown object type");
