klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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:
Msrc/Makefile | 11+++++++----
Asrc/kcondvar.c | 107+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/kcondvar.h | 27+++++++++++++++++++++++++++
Msrc/kgc.c | 13++++++++++++-
Msrc/kgthreads.c | 70+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
Msrc/kmutex.c | 2--
Msrc/kmutex.h | 1+
Msrc/kobject.h | 11+++++++++++
Msrc/kwrite.c | 9+++++++++
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");