commit 2ae03fef7b1da19bd6ba56d788c83b05058cedc0
parent 16a7dd113090e31f05d019b9372cc9bb0bfb691a
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sat, 25 Aug 2012 14:34:41 -0300
Temporarily moved all locking to the main thread loop. This will limit parallelism for now but will alow gradual rewrite of all operatives and continuations.
Diffstat:
18 files changed, 31 insertions(+), 85 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -2,4 +2,6 @@ v0.4
- Added eq-hashtables (Oto Havle)
- Fixed semantics of eval in the presence of continuation capturing
- and mutation of the argument or result list
-\ No newline at end of file
+ and mutation of the argument or result list
+- Fixed semantics of other combiners in the presence of continuation capturing
+ and mutation (filter)
diff --git a/TODO b/TODO
@@ -1,3 +1,8 @@
+- Check lambda for problems with continuation capturing
+- Check the let family for problems with continuation capturing
+- Check map for problems with continuation capturing
+
+
* Release 0.4+
** refactor:
*** clean stand alone interpreter
diff --git a/src/imath.c b/src/imath.c
@@ -374,9 +374,7 @@ mp_result mp_int_init(mp_int z)
mp_int mp_int_alloc(klisp_State *K)
{
- klisp_lock(K);
mp_int out = klispM_new(K, mpz_t);
- klisp_unlock(K);
if(out != NULL)
mp_int_init(out);
@@ -490,9 +488,7 @@ void mp_int_free(klisp_State *K, mp_int z)
NRCHECK(z != NULL);
mp_int_clear(K, z);
- klisp_lock(K);
klispM_free(K, z); /* note: NOT s_free() */
- klisp_unlock(K);
}
/* }}} */
@@ -2212,9 +2208,7 @@ const char *mp_error_string(mp_result res)
STATIC mp_digit *s_alloc(klisp_State *K, mp_size num)
{
- klisp_lock(K);
mp_digit *out = klispM_malloc(K, num * sizeof(mp_digit));
- klisp_unlock(K);
assert(out != NULL); /* for debugging */
#if DEBUG > 1
@@ -2246,10 +2240,8 @@ STATIC mp_digit *s_realloc(klisp_State *K, mp_digit *old, mp_size osize,
memcpy(new, old, osize * sizeof(mp_digit));
#else
- klisp_lock(K);
mp_digit *new = klispM_realloc_(K, old, osize * sizeof(mp_digit),
nsize * sizeof(mp_digit));
- klisp_unlock(K);
assert(new != NULL); /* for debugging */
#endif
return new;
@@ -2261,9 +2253,7 @@ STATIC mp_digit *s_realloc(klisp_State *K, mp_digit *old, mp_size osize,
STATIC void s_free(klisp_State *K, void *ptr, mp_size size)
{
- klisp_lock(K);
klispM_freemem(K, ptr, size * sizeof(mp_digit));
- klisp_unlock(K);
}
/* }}} */
diff --git a/src/imrat.c b/src/imrat.c
@@ -59,15 +59,11 @@ mp_result mp_rat_init(klisp_State *K, mp_rat r)
mp_rat mp_rat_alloc(klisp_State *K)
{
- klisp_lock(K);
mp_rat out = klispM_new(K, mpq_t);
- klisp_unlock(K);
if(out != NULL) {
if(mp_rat_init(K, out) != MP_OK) {
- klisp_lock(K);
klispM_free(K, out);
- klisp_unlock(K);
return NULL;
}
}
@@ -150,9 +146,7 @@ void mp_rat_free(klisp_State *K, mp_rat r)
if(r->num.digits != NULL)
mp_rat_clear(K, r);
- klisp_lock(K);
klispM_free(K, r);
- klisp_unlock(K);
}
/* }}} */
diff --git a/src/kapplicative.c b/src/kapplicative.c
@@ -13,7 +13,6 @@
/* GC: Assumes underlying is rooted */
TValue kwrap(klisp_State *K, TValue underlying)
{
- klisp_lock(K);
Applicative *new_app = klispM_new(K, Applicative);
/* header + gc_fields */
@@ -22,6 +21,5 @@ TValue kwrap(klisp_State *K, TValue underlying)
/* applicative specific fields */
new_app->underlying = underlying;
- klisp_unlock(K);
return gc2app(new_app);
}
diff --git a/src/kbytevector.c b/src/kbytevector.c
@@ -70,12 +70,11 @@ static Bytevector *search_in_bb_table(klisp_State *K, const uint8_t *buf,
TValue kbytevector_new_bs_imm(klisp_State *K, const uint8_t *buf, uint32_t size)
{
uint32_t h = get_bytevector_hash(buf, size);
- klisp_lock(K);
+
/* first check to see if it's in the stringtable */
Bytevector *new_bb = search_in_bb_table(K, buf, size, h);
if (new_bb != NULL) { /* found */
- klisp_unlock(K);
return gc2bytevector(new_bb);
}
@@ -118,7 +117,6 @@ TValue kbytevector_new_bs_imm(klisp_State *K, const uint8_t *buf, uint32_t size)
krooted_tvs_pop(K);
}
- klisp_unlock(K);
return ret_tv;
}
@@ -137,7 +135,6 @@ TValue kbytevector_new_s(klisp_State *K, uint32_t size)
return G(K)->empty_bytevector;
}
- klisp_lock(K);
new_bb = klispM_malloc(K, sizeof(Bytevector) + size);
/* header + gc_fields */
@@ -148,7 +145,6 @@ TValue kbytevector_new_s(klisp_State *K, uint32_t size)
new_bb->size = size;
/* the buffer is initialized elsewhere */
- klisp_unlock(K);
return gc2bytevector(new_bb);
}
@@ -187,12 +183,8 @@ bool kbytevector_equalp(klisp_State *K, TValue obj1, TValue obj2)
Bytevector *bytevector2 = tv2bytevector(obj2);
if (bytevector1->size == bytevector2->size) {
- bool res;
- klisp_lock(K);
- res = (bytevector1->size == 0) ||
+ return (bytevector1->size == 0) ||
(memcmp(bytevector1->b, bytevector2->b, bytevector1->size) == 0);
- klisp_unlock(K);
- return res;
} else {
return false;
}
diff --git a/src/kcontinuation.c b/src/kcontinuation.c
@@ -19,7 +19,6 @@ TValue kmake_continuation(klisp_State *K, TValue parent, klisp_CFunction fn,
{
va_list argp;
- klisp_lock(K);
Continuation *new_cont = (Continuation *)
klispM_malloc(K, sizeof(Continuation) + sizeof(TValue) * xcount);
@@ -51,7 +50,6 @@ TValue kmake_continuation(klisp_State *K, TValue parent, klisp_CFunction fn,
/* TODO: find all the places where this should be changed (like $and?,
$sequence), and change it */
kset_source_info(K, res, kget_csi(K));
- klisp_unlock(K);
return res;
}
@@ -130,7 +128,6 @@ static TValue select_interceptor(TValue guard_ls)
TValue create_interception_list(klisp_State *K, TValue src_cont,
TValue dst_cont)
{
- klisp_lock(K);
mark_iancestors(dst_cont);
TValue ilist = kcons(K, KNIL, KNIL);
krooted_vars_push(K, &ilist);
@@ -205,7 +202,6 @@ TValue create_interception_list(klisp_State *K, TValue src_cont,
/* all interceptions collected, append the two lists and return */
kset_cdr(tail, entry_int);
- klisp_unlock(K);
krooted_vars_pop(K);
krooted_vars_pop(K);
return kcdr(ilist);
diff --git a/src/kencapsulation.c b/src/kencapsulation.c
@@ -19,7 +19,6 @@ bool kis_encapsulation_type(TValue enc, TValue key)
/* GC: Assumes that key & val are rooted */
TValue kmake_encapsulation(klisp_State *K, TValue key, TValue val)
{
- klisp_lock(K);
Encapsulation *new_enc = klispM_new(K, Encapsulation);
/* header + gc_fields */
@@ -29,7 +28,6 @@ TValue kmake_encapsulation(klisp_State *K, TValue key, TValue val)
new_enc->key = key;
new_enc->value = val;
- klisp_unlock(K);
return gc2enc(new_enc);
}
diff --git a/src/kenvironment.c b/src/kenvironment.c
@@ -29,7 +29,6 @@
/* GC: Assumes that parents is rooted */
TValue kmake_environment(klisp_State *K, TValue parents)
{
- klisp_lock(K);
Environment *new_env = klispM_new(K, Environment);
/* header + gc_fields */
@@ -88,7 +87,6 @@ TValue kmake_environment(klisp_State *K, TValue parents)
kparents = kcar(kparents);
}
new_env->keyed_parents = kparents; /* overwrite with the proper value */
- klisp_unlock(K);
return gc2env(new_env);
}
@@ -124,7 +122,6 @@ TValue kfind_local_binding(klisp_State *K, TValue bindings, TValue sym)
/* GC: Assumes that obj & sym are rooted. */
void ktry_set_name(klisp_State *K, TValue obj, TValue sym)
{
- klisp_lock(K);
if (kcan_have_name(obj) && !khas_name(obj)) {
/* TODO: maybe we could have some kind of inheritance so
that if this object receives a name it can pass on that
@@ -150,7 +147,6 @@ void ktry_set_name(klisp_State *K, TValue obj, TValue sym)
}
}
}
- klisp_unlock(K);
}
/* Assumes obj has a name */
@@ -176,7 +172,6 @@ void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val)
/* lock early because it is possible that even the environment
type changes (from list to table) */
- klisp_lock(K);
TValue bindings = kenv_bindings(K, env);
if (ttistable(bindings)) {
TValue *cell = klispH_setsym(K, tv2table(bindings), tv2sym(sym));
@@ -193,7 +188,6 @@ void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val)
kset_cdr(oldb, val);
}
}
- klisp_unlock(K);
}
/* This works no matter if parents is a list or a single environment */
@@ -201,7 +195,6 @@ void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val)
static inline bool try_get_binding(klisp_State *K, TValue env, TValue sym,
TValue *value)
{
- klisp_lock(K);
/* assume the stack may be in use, keep track of pushed objs */
int pushed = 1;
ks_spush(K, env);
@@ -243,7 +236,6 @@ static inline bool try_get_binding(klisp_State *K, TValue env, TValue sym,
*value = KINERT;
- klisp_unlock(K);
return false;
}
@@ -276,9 +268,7 @@ TValue kmake_keyed_static_env(klisp_State *K, TValue parent, TValue key,
{
TValue new_env = kmake_environment(K, parent);
krooted_tvs_push(K, new_env); /* keep the env rooted */
- klisp_lock(K);
env_keyed_node(new_env) = kcons(K, key, val);
- klisp_unlock(K);
krooted_tvs_pop(K);
return new_env;
}
@@ -291,7 +281,6 @@ static inline bool try_get_keyed(klisp_State *K, TValue env, TValue key,
repetition */
/* assume the stack may be in use, keep track of pushed objs */
- klisp_lock(K);
int pushed = 1;
if (!env_is_keyed(env))
env = env_keyed_parents(env);
@@ -320,7 +309,6 @@ static inline bool try_get_keyed(klisp_State *K, TValue env, TValue key,
pushed += 2;
}
}
- klisp_unlock(K);
*value = KINERT;
return false;
}
@@ -344,9 +332,7 @@ TValue kmake_table_environment(klisp_State *K, TValue parents)
TValue new_env = kmake_environment(K, parents);
krooted_tvs_push(K, new_env);
TValue new_table = klispH_new(K, 0, ENVTABSIZE, K_FLAG_WEAK_NOTHING);
- klisp_lock(K);
tv2env(new_env)->bindings = new_table;
- klisp_unlock(K);
krooted_tvs_pop(K);
return new_env;
}
diff --git a/src/kerror.c b/src/kerror.c
@@ -18,7 +18,6 @@
TValue klispE_new(klisp_State *K, TValue who, TValue cont, TValue msg,
TValue irritants)
{
- klisp_lock(K);
Error *new_error = klispM_new(K, Error);
/* header + gc_fields */
@@ -29,7 +28,6 @@ TValue klispE_new(klisp_State *K, TValue who, TValue cont, TValue msg,
new_error->cont = cont;
new_error->msg = msg;
new_error->irritants = irritants;
- klisp_unlock(K);
return gc2error(new_error);
}
@@ -89,7 +87,6 @@ void klispE_throw_simple(klisp_State *K, char *msg)
/* clear buffer shouldn't cause GC, but just in case... */
krooted_tvs_push(K, error_obj);
clear_buffers(K); /* this pops both error_msg & error_obj */
- klisp_unlock_all(K); /* is this thread holds the GIL release it */
/* call_cont protects error from gc */
kcall_cont(K, G(K)->error_cont, error_obj);
}
@@ -115,7 +112,6 @@ void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants)
/* clear buffer shouldn't cause GC, but just in case... */
krooted_tvs_push(K, error_obj);
clear_buffers(K); /* this pops both error_msg & error_obj */
- klisp_unlock_all(K); /* is this thread holds the GIL release it */
/* call_cont protects error from gc */
kcall_cont(K, G(K)->error_cont, error_obj);
}
@@ -127,7 +123,6 @@ void klispE_throw_system_error_with_irritants(
irritants);
krooted_tvs_push(K, error_obj);
clear_buffers(K);
- klisp_unlock_all(K); /* is this thread holds the GIL release it */
kcall_cont(K, G(K)->system_error_cont, error_obj);
}
diff --git a/src/keval.c b/src/keval.c
@@ -173,10 +173,8 @@ void keval_ofn(klisp_State *K)
switch(ttype(obj)) {
case K_TPAIR: {
- klisp_lock(K);
TValue operator = kcar(obj);
TValue operands = kcdr(obj);
- klisp_unlock(K);
TValue new_cont =
kmake_continuation(K, kget_cc(K), do_combine_operands, 3,
operands, denv, ktry_get_si(K, obj));
diff --git a/src/kgerrors.h b/src/kgerrors.h
@@ -11,5 +11,7 @@
/* init ground */
void kinit_error_ground_env(klisp_State *K);
+/* init cont names */
+void kinit_error_cont_names(klisp_State *K);
#endif
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -394,8 +394,6 @@ void check_typed_list(klisp_State *K, bool (*typep)(TValue), bool allow_infp,
int32_t p = 0;
bool type_errorp = false;
- klisp_lock(K);
-
while(ttispair(tail) && !kis_marked(tail)) {
/* even if there is a type error continue checking the structure */
type_errorp |= !(*typep)(kcar(tail));
@@ -410,8 +408,6 @@ void check_typed_list(klisp_State *K, bool (*typep)(TValue), bool allow_infp,
unmark_list(K, obj);
- klisp_unlock(K);
-
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_simple(K, allow_infp? "expected list" :
"expected finite list");
@@ -433,7 +429,6 @@ void check_list(klisp_State *K, bool allow_infp, TValue obj,
TValue tail = obj;
int32_t p = 0;
- klisp_lock(K);
while(ttispair(tail) && !kis_marked(tail)) {
kset_mark(tail, i2tv(p));
tail = kcdr(tail);
@@ -445,7 +440,6 @@ void check_list(klisp_State *K, bool allow_infp, TValue obj,
*cpairs = ttispair(tail)? (p - ivalue(kget_mark(tail))) : 0;
unmark_list(K, obj);
- klisp_unlock(K);
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_simple(K, allow_infp? "expected list" :
@@ -478,7 +472,6 @@ TValue check_copy_list(klisp_State *K, TValue obj, bool force_copy,
TValue last_pair = copy;
TValue tail = obj;
- klisp_lock(K);
while(ttispair(tail) && !kis_marked(tail)) {
TValue new_pair = kcons(K, kcar(tail), KNIL);
/* record the corresponding pair to simplify cycle handling */
@@ -508,7 +501,6 @@ TValue check_copy_list(klisp_State *K, TValue obj, bool force_copy,
unmark_list(K, obj);
unmark_list(K, kcdr(copy));
- klisp_unlock(K);
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_simple(K, "expected list");
diff --git a/src/kgsystem.c b/src/kgsystem.c
@@ -103,17 +103,21 @@ void delete_file(klisp_State *K)
/* TEMP: this should probably be done in a operating system specific
manner, but this will do for now */
+ /* allow other threads to run while the file is being removed */
+ klisp_unlock(K);
if (remove(kstring_buf(filename))) {
/* At least in Windows, this could have failed if there's a dead
(in the gc sense) port still open, should retry once after
doing a complete GC. This isn't ideal but... */
klisp_lock(K);
klispC_fullgc(K);
- klisp_unlock(K);
+ klisp_unlock(K);
if (remove(kstring_buf(filename))) {
+ klisp_lock(K);
klispE_throw_errno_with_irritants(K, "remove", 1, filename);
return;
}
+ klisp_lock(K);
}
kapply_cc(K, KINERT);
}
diff --git a/src/klimits.h b/src/klimits.h
@@ -105,6 +105,7 @@
--K->gil_count; \
}})
+/* this will work no matter how many times (even 0) the lock was acquired */
#define klisp_unlock_all(K) ({ \
if (K->gil_count > 0) { \
K->gil_count = 1; \
diff --git a/src/kmem.c b/src/kmem.c
@@ -96,7 +96,7 @@ void *klispM_realloc_ (klisp_State *K, void *block, size_t osize, size_t nsize)
if (block == NULL && nsize > 0) {
/* TEMP: try GC if there is no more mem */
/* TODO: make this a catchable error */
- klisp_unlock(K);
+ klisp_unlock_all(K);
fprintf(stderr, MEMERRMSG);
abort();
}
diff --git a/src/kstate.c b/src/kstate.c
@@ -402,7 +402,6 @@ klisp_State *klisp_newthread(klisp_State *K)
klisp_State *klispT_newthread(klisp_State *K)
{
- klisp_lock(K);
klisp_State *K1 = tostate(klispM_malloc(K, state_size(klisp_State)));
klispC_link(K, (GCObject *) K1, K_TTHREAD, 0);
preinit_state(K1, G(K));
@@ -417,19 +416,16 @@ klisp_State *klispT_newthread(klisp_State *K)
ks_tbidx(K1) = 0; /* buffer is empty */
klisp_assert(iswhite((GCObject *) (K1)));
- klisp_unlock(K);
return K1;
}
void klispT_freethread (klisp_State *K, klisp_State *K1)
{
- klisp_lock(K);
klispM_freemem(K, ks_sbuf(K1), ks_ssize(K1) * sizeof(TValue));
klispM_freemem(K, ks_tbuf(K1), ks_tbsize(K1));
/* userstatefree() */
klispM_freemem(K, fromstate(K1), state_size(klisp_State));
- klisp_unlock(K);
}
void klisp_close (klisp_State *K)
@@ -566,20 +562,31 @@ void klispT_init_repl(klisp_State *K)
kinit_repl(K);
}
+/*
+** TEMP/LOCK: put lock here, until all operatives and continuations do locking directly
+** or a new interface (like lua api) does it for them.
+** This has the problem that nothing can be done in parallel (but still has the advantage
+** that (unlike coroutines) when one thread is blocked (e.g. waiting for IO) the others
+** may continue (provided that the blocked thread unlocks the GIL before blocking...)
+*/
void klispT_run(klisp_State *K)
{
while(true) {
if (setjmp(K->error_jb)) {
/* continuation called */
/* TEMP: do nothing, the loop will call the continuation */
+ klisp_unlock_all(K);
} else {
+ klisp_lock(K);
/* all ok, continue with next func */
while (K->next_func) {
/* next_func is either operative or continuation
but in any case the call is the same */
(*(K->next_func))(K);
+ klispi_threadyield(K);
}
/* K->next_func is NULL, this means we should exit already */
+ klisp_unlock(K);
break;
}
}
diff --git a/src/kstate.h b/src/kstate.h
@@ -461,7 +461,6 @@ static inline void klispT_apply_cc(klisp_State *K, TValue val)
{
/* TODO write barriers */
- klisp_lock(K);
/* various assert to check the freeing of gc protection methods */
/* TODO add marks assertions */
klisp_assert(K->rooted_tvs_top == 0);
@@ -476,26 +475,20 @@ static inline void klispT_apply_cc(klisp_State *K, TValue val)
K->next_xparams = cont->extra;
K->curr_cont = cont->parent;
K->next_si = ktry_get_si(K, K->next_obj);
- klisp_unlock(K);
}
#define kapply_cc(K_, val_) klispT_apply_cc((K_), (val_)); return
static inline TValue klispT_get_cc(klisp_State *K)
{
- klisp_lock(K);
- TValue res = K->curr_cont;
- klisp_unlock(K);
- return res;
+ return K->curr_cont;
}
#define kget_cc(K_) (klispT_get_cc(K_))
static inline void klispT_set_cc(klisp_State *K, TValue new_cont)
{
- klisp_lock(K);
K->curr_cont = new_cont;
- klisp_unlock(K);
}
#define kset_cc(K_, c_) (klispT_set_cc(K_, c_))
@@ -504,7 +497,6 @@ static inline void klispT_tail_call_si(klisp_State *K, TValue top, TValue ptree,
TValue env, TValue si)
{
/* TODO write barriers */
- klisp_lock(K);
/* various assert to check the freeing of gc protection methods */
klisp_assert(K->rooted_tvs_top == 0);
klisp_assert(K->rooted_vars_top == 0);
@@ -518,7 +510,6 @@ static inline void klispT_tail_call_si(klisp_State *K, TValue top, TValue ptree,
K->next_env = env;
K->next_xparams = op->extra;
K->next_si = si;
- klisp_unlock(K);
}
#define ktail_call_si(K_, op_, p_, e_, si_) \
@@ -528,17 +519,13 @@ static inline void klispT_tail_call_si(klisp_State *K, TValue top, TValue ptree,
#define ktail_call(K_, op_, p_, e_) \
{ klisp_State *K__ = (K_); \
TValue op__ = (op_); \
- klisp_lock(K); \
TValue si__ = ktry_get_si(K__, op__); \
- klisp_unlock(K); \
(ktail_call_si(K__, op__, p_, e_, si__)); } \
#define ktail_eval(K_, p_, e_) \
{ klisp_State *K__ = (K_); \
TValue p__ = (p_); \
- klisp_lock(K); \
TValue si__ = ktry_get_si(K__, p__); \
- klisp_unlock(K); \
klispT_tail_call_si(K__, G(K__)->eval_op, p__, (e_), si__); \
return; }
