mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-04-25 02:50:24 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'threading-fixes' into 'develop'

Browse source 
Threading fixes

Closes #419

See merge request embeddable-common-lisp/ecl!100
This commit is contained in:
Daniel Kochmański 2018-03-16 15:08:27 +00:00
commit c09256866f
24 changed files with 643 additions and 300 deletions
Download patch file Download diff file Expand all files Collapse all files

7
src/c/alloc_2.d
View file

@ -268,7 +268,10 @@ allocate_object_own(register struct ecl_type_information *type_info)
if( (op = *opp) == 0 ) {
UNLOCK();
op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind);
if (0 == op) return 0;
if (0 == op){
ecl_enable_interrupts_env(the_env);
return 0;
}
lg = GC_size_map[lb]; /* May have been uninitialized. */
} else {
*opp = obj_link(op);
@ -1350,7 +1353,7 @@ ecl_mark_env(struct cl_env_struct *env)
static void
stacks_scanner()
{
cl_env_ptr the_env = ecl_process_env();
cl_env_ptr the_env = ecl_process_env_unsafe();
cl_object l;
l = cl_core.libraries;
if (l) {

18
src/c/clos/accessor.d
View file

@ -71,8 +71,12 @@ static ecl_cache_record_ptr
search_slot_index(const cl_env_ptr env, cl_object gfun, cl_object instance)
{
ecl_cache_ptr cache = env->slot_cache;
fill_spec_vector(cache->keys, gfun, instance);
return ecl_search_cache(cache);
ecl_cache_record_ptr ret;
ECL_WITHOUT_INTERRUPTS_BEGIN(env) {
fill_spec_vector(cache->keys, gfun, instance);
ret = ecl_search_cache(cache);
} ECL_WITHOUT_INTERRUPTS_END;
return ret;
}
static ecl_cache_record_ptr
@ -89,10 +93,12 @@ add_new_index(const cl_env_ptr env, cl_object gfun, cl_object instance, cl_objec
{
ecl_cache_record_ptr e;
ecl_cache_ptr cache = env->slot_cache;
fill_spec_vector(cache->keys, gfun, instance);
e = ecl_search_cache(cache);
e->key = cl_copy_seq(cache->keys);
e->value = index;
ECL_WITHOUT_INTERRUPTS_BEGIN(env) {
fill_spec_vector(cache->keys, gfun, instance);
e = ecl_search_cache(cache);
e->key = cl_copy_seq(cache->keys);
e->value = index;
} ECL_WITHOUT_INTERRUPTS_END;
return e;
}
}

1
src/c/clos/cache.d
View file

@ -126,6 +126,7 @@ vector_hash_key(cl_object keys)
/*
* variation of ecl_gethash from hash.d, which takes an array of objects as key
* It also assumes that entries are never removed except by clrhash.
* This method must be called with interrupts disabled!
*/
ecl_cache_record_ptr

36
src/c/clos/gfun.d
View file

@ -232,25 +232,27 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf)
}
#endif
vector = fill_spec_vector(cache->keys, frame, gf);
e = ecl_search_cache(cache);
if (e->key != OBJNULL) {
func = e->value;
} else {
/* The keys and the cache may change while we
* compute the applicable methods. We must save
* the keys and recompute the cache location if
* it was filled. */
cl_object keys = cl_copy_seq(vector);
func = compute_applicable_method(env, frame, gf);
if (env->values[1] != ECL_NIL) {
if (e->key != OBJNULL) {
e = ecl_search_cache(cache);
ECL_WITHOUT_INTERRUPTS_BEGIN(env) {
vector = fill_spec_vector(cache->keys, frame, gf);
e = ecl_search_cache(cache);
if (e->key != OBJNULL) {
func = e->value;
} else {
/* The keys and the cache may change while we
* compute the applicable methods. We must save
* the keys and recompute the cache location if
* it was filled. */
cl_object keys = cl_copy_seq(vector);
func = compute_applicable_method(env, frame, gf);
if (env->values[1] != ECL_NIL) {
if (e->key != OBJNULL) {
e = ecl_search_cache(cache);
}
e->key = keys;
e->value = func;
}
e->key = keys;
e->value = func;
}
}
} ECL_WITHOUT_INTERRUPTS_END;
if (func == ECL_NIL)
func = cl_apply(3, @'no-applicable-method', gf, frame);
else

17
src/c/interpreter.d
View file

@ -17,6 +17,7 @@
#include <ecl/ecl-inl.h>
#include <ecl/bytecodes.h>
#include <ecl/internal.h>
#include <ecl/stack-resize.h>
/* -------------------- INTERPRETER STACK -------------------- */
@ -38,14 +39,13 @@ ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size)
old_stack = env->stack;
new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object));
ecl_disable_interrupts_env(env);
ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env);
memcpy(new_stack, old_stack, env->stack_size * sizeof(cl_object));
env->stack_size = new_size;
env->stack_limit_size = new_size - 2*safety_area;
env->stack = new_stack;
env->stack_top = env->stack + top;
env->stack_limit = env->stack + (new_size - 2*safety_area);
ecl_enable_interrupts_env(env);
/* A stack always has at least one element. This is assumed by cl__va_start
* and friends, which take a sp=0 to have no arguments.
@ -53,6 +53,8 @@ ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size)
if (top == 0) {
*(env->stack_top++) = ecl_make_fixnum(0);
}
ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env);
return env->stack_top;
}
@ -124,8 +126,8 @@ ecl_stack_frame_push(cl_object f, cl_object o)
if (top >= env->stack_limit) {
top = ecl_stack_grow(env);
}
*top = o;
env->stack_top = ++top;
*(top-1) = o;
f->frame.base = top - (++(f->frame.size));
f->frame.stack = env->stack;
}
@ -994,7 +996,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
GET_LABEL(exit, vector);
ECL_STACK_PUSH(the_env, lex_env);
ECL_STACK_PUSH(the_env, (cl_object)exit);
if (ecl_frs_push(the_env,reg1) == 0) {
ecl_frs_push(the_env,reg1);
if (__ecl_frs_push_result == 0) {
THREAD_NEXT;
} else {
reg0 = the_env->values[0];
@ -1022,7 +1025,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
ECL_STACK_PUSH(the_env, lex_env);
ECL_STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */
vector += n * OPARG_SIZE;
if (ecl_frs_push(the_env,reg1) != 0) {
ecl_frs_push(the_env,reg1);
if (__ecl_frs_push_result != 0) {
/* Wait here for gotos. Each goto sets
VALUES(0) to an integer which ranges from 0
to ntags-1, depending on the tag. These
@ -1148,7 +1152,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
GET_LABEL(exit, vector);
ECL_STACK_PUSH(the_env, lex_env);
ECL_STACK_PUSH(the_env, (cl_object)exit);
if (ecl_frs_push(the_env,ECL_PROTECT_TAG) != 0) {
ecl_frs_push(the_env,ECL_PROTECT_TAG);
if (__ecl_frs_push_result != 0) {
ecl_frs_pop(the_env);
vector = (cl_opcode *)ECL_STACK_POP_UNSAFE(the_env);
lex_env = ECL_STACK_POP_UNSAFE(the_env);

43
src/c/main.d
View file

@ -162,10 +162,10 @@ ecl_init_env(cl_env_ptr env)
env->method_cache = ecl_make_cache(64, 4096);
env->slot_cache = ecl_make_cache(3, 4096);
env->pending_interrupt = ECL_NIL;
env->interrupt_struct->pending_interrupt = ECL_NIL;
{
int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE];
env->signal_queue = cl_make_list(1, ecl_make_fixnum(size));
env->interrupt_struct->signal_queue = cl_make_list(1, ecl_make_fixnum(size));
}
init_stacks(env);
@ -239,6 +239,10 @@ _ecl_alloc_env(cl_env_ptr parent)
}
# endif
#endif
if (!ecl_option_values[ECL_OPT_BOOTED])
output->interrupt_struct = ecl_alloc_unprotected(sizeof(*output->interrupt_struct));
else
output->interrupt_struct = ecl_alloc(sizeof(*output->interrupt_struct));
{
size_t bytes = cl_core.default_sigmask_bytes;
if (bytes == 0) {
@ -257,8 +261,8 @@ _ecl_alloc_env(cl_env_ptr parent)
* are activated later on by the thread entry point or init_unixint().
*/
output->disable_interrupts = 1;
output->pending_interrupt = ECL_NIL;
output->signal_queue_spinlock = ECL_NIL;
output->interrupt_struct->pending_interrupt = ECL_NIL;
output->interrupt_struct->signal_queue_spinlock = ECL_NIL;
return output;
}
@ -553,6 +557,24 @@ cl_boot(int argc, char **argv)
#endif
env->packages_to_be_created = ECL_NIL;
#ifdef ECL_THREADS
env->bindings_array = si_make_vector(ECL_T, ecl_make_fixnum(1024),
ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL);
si_fill_array_with_elt(env->bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL);
env->thread_local_bindings_size = env->bindings_array->vector.dim;
env->thread_local_bindings = env->bindings_array->vector.self.t;
#endif
/*
* Initialize the per-thread data.
* This cannot come later, because we need to be able to bind
* ext::*interrupts-enabled while creating packages.
*/
init_big();
ecl_init_env(env);
ecl_cs_set_org(env);
cl_core.lisp_package =
ecl_make_package(str_common_lisp,
cl_list(2, str_cl, str_LISP),
@ -619,14 +641,6 @@ cl_boot(int argc, char **argv)
/* These must come _after_ the packages and NIL/T have been created */
init_all_symbols();
/*
* Initialize the per-thread data.
* This cannot come later, because some routines need the
* frame stack immediately (for instance SI:PATHNAME-TRANSLATIONS).
*/
init_big();
ecl_init_env(env);
ecl_cs_set_org(env);
#if !defined(GBC_BOEHM)
/* We need this because a lot of stuff is to be created */
init_GC();
@ -644,11 +658,6 @@ cl_boot(int argc, char **argv)
#endif
#ifdef ECL_THREADS
env->bindings_array = si_make_vector(ECL_T, ecl_make_fixnum(1024),
ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL);
si_fill_array_with_elt(env->bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL);
env->thread_local_bindings_size = env->bindings_array->vector.dim;
env->thread_local_bindings = env->bindings_array->vector.self.t;
ECL_SET(@'mp::*current-process*', env->own_process);
#endif

91
src/c/stacks.d
View file

@ -20,6 +20,7 @@
# include <sys/resource.h>
#endif
#include <ecl/internal.h>
#include <ecl/stack-resize.h>
/************************ C STACK ***************************/
@ -139,13 +140,13 @@ ecl_bds_set_size(cl_env_ptr env, cl_index new_size)
env->bds_limit_size = new_size - 2*margin;
org = ecl_alloc_atomic(new_size * sizeof(*org));
ecl_disable_interrupts_env(env);
ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env);
memcpy(org, old_org, (limit + 1) * sizeof(*org));
env->bds_top = org + limit;
env->bds_org = org;
env->bds_limit = org + (new_size - 2*margin);
env->bds_size = new_size;
ecl_enable_interrupts_env(env);
ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env);
ecl_dealloc(old_org);
}
@ -183,7 +184,7 @@ ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index)
#ifdef ECL_THREADS
ecl_bds_unwind1(env);
#else
bds->symbol->symbol.value = bds->value;
bds->symbol->symbol.value = bds->value;
#endif
env->bds_top = new_bds_top;
}
@ -320,16 +321,29 @@ ecl_bds_bind(cl_env_ptr env, cl_object s, cl_object v)
index = invalid_or_too_large_binding_index(env,s);
}
location = env->thread_local_bindings + index;
slot = ++env->bds_top;
if (slot >= env->bds_limit) slot = ecl_bds_overflow();
slot = env->bds_top+1;
if (slot >= env->bds_limit){
slot = ecl_bds_overflow();
slot->symbol = ECL_DUMMY_TAG;
} else {
slot->symbol = ECL_DUMMY_TAG;
AO_nop_full();
++env->bds_top;
}
AO_nop_full();
ecl_disable_interrupts_env(env);
slot->symbol = s;
slot->value = *location;
*location = v;
ecl_enable_interrupts_env(env);
#else
ecl_bds_check(env);
(++(env->bds_top))->symbol = s;
env->bds_top->value = s->symbol.value; \
ecl_bds_ptr slot = ++(env->bds_top);
ecl_disable_interrupts_env(env);
slot->symbol = s;
slot->value = s->symbol.value;
s->symbol.value = v;
ecl_enable_interrupts_env(env);
#endif
}
@ -344,29 +358,42 @@ ecl_bds_push(cl_env_ptr env, cl_object s)
index = invalid_or_too_large_binding_index(env,s);
}
location = env->thread_local_bindings + index;
slot = ++env->bds_top;
if (slot >= env->bds_limit) slot = ecl_bds_overflow();
slot = env->bds_top+1;
if (slot >= env->bds_limit){
slot = ecl_bds_overflow();
slot->symbol = ECL_DUMMY_TAG;
} else {
slot->symbol = ECL_DUMMY_TAG;
AO_nop_full();
++env->bds_top;
}
AO_nop_full();
ecl_disable_interrupts_env(env);
slot->symbol = s;
slot->value = *location;
if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value;
ecl_enable_interrupts_env(env);
#else
ecl_bds_check(env);
(++(env->bds_top))->symbol = s;
env->bds_top->value = s->symbol.value;
ecl_bds_ptr slot = ++(env->bds_top);
ecl_disable_interrupts_env(env);
slot->symbol = s;
slot->value = s->symbol.value;
ecl_enable_interrupts_env(env);
#endif
}
void
ecl_bds_unwind1(cl_env_ptr env)
{
ecl_bds_ptr slot = env->bds_top--;
cl_object s = slot->symbol;
cl_object s = env->bds_top->symbol;
#ifdef ECL_THREADS
cl_object *location = env->thread_local_bindings + s->symbol.binding;
*location = slot->value;
*location = env->bds_top->value;
#else
s->symbol.value = slot->value;
s->symbol.value = env->bds_top->value;
#endif
--env->bds_top;
}
#ifdef ECL_THREADS
@ -495,13 +522,13 @@ frs_set_size(cl_env_ptr env, cl_index new_size)
env->frs_limit_size = new_size - 2*margin;
org = ecl_alloc_atomic(new_size * sizeof(*org));
ecl_disable_interrupts_env(env);
ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env);
memcpy(org, old_org, (limit + 1) * sizeof(*org));
env->frs_top = org + limit;
env->frs_org = org;
env->frs_limit = org + (new_size - 2*margin);
env->frs_size = new_size;
ecl_enable_interrupts_env(env);
ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env);
ecl_dealloc(old_org);
}
@ -532,13 +559,23 @@ frs_overflow(void) /* used as condition in list.d */
ecl_frame_ptr
_ecl_frs_push(register cl_env_ptr env, register cl_object val)
{
ecl_frame_ptr output = ++env->frs_top;
if (output >= env->frs_limit) {
/* We store a dummy tag first, to make sure that it is safe to
* interrupt this method with a call to ecl_unwind. Otherwise, a
* stray ECL_PROTECT_TAG will lead to segfaults. AO_nop_full is
* needed to ensure that the CPU doesn't reorder the memory
* stores. */
ecl_frame_ptr output = env->frs_top+1;
if (output >= env->frs_limit){
frs_overflow();
output = env->frs_top;
output->frs_val = ECL_DUMMY_TAG;
} else {
output->frs_val = ECL_DUMMY_TAG;
AO_nop_full();
++env->frs_top;
}
AO_nop_full();
output->frs_bds_top_index = env->bds_top - env->bds_org;
output->frs_val = val;
output->frs_ihs = env->ihs_top;
output->frs_sp = ECL_STACK_INDEX(env);
return output;
@ -548,11 +585,15 @@ void
ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr)
{
env->nlj_fr = fr;
while (env->frs_top != fr && env->frs_top->frs_val != ECL_PROTECT_TAG)
--env->frs_top;
env->ihs_top = env->frs_top->frs_ihs;
ecl_bds_unwind(env, env->frs_top->frs_bds_top_index);
ECL_STACK_SET_INDEX(env, env->frs_top->frs_sp);
ecl_frame_ptr top = env->frs_top;
while (top != fr && top->frs_val != ECL_PROTECT_TAG){
top->frs_val = ECL_DUMMY_TAG;
--top;
}
env->ihs_top = top->frs_ihs;
ecl_bds_unwind(env, top->frs_bds_top_index);
ECL_STACK_SET_INDEX(env, top->frs_sp);
env->frs_top = top;
ecl_longjmp(env->frs_top->frs_jmpbuf, 1);
/* never reached */
}

3
src/c/symbols_list.h
View file

@ -74,8 +74,10 @@ cl_symbols[] = {
{"T", CL_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "UNBOUND", SI_CONSTANT, si_unbound, 0, ECL_UNBOUND},
{SYS_ "PROTECT-TAG", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "DUMMY-TAG", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "*RESTART-CLUSTERS*", SI_SPECIAL, NULL, -1, Cnil},
{SYS_ "*HANDLER-CLUSTERS*", SI_SPECIAL, NULL, -1, Cnil},
{EXT_ "*INTERRUPTS-ENABLED*", EXT_SPECIAL, NULL, 1, ECL_T},
/* LISP PACKAGE */
{"&ALLOW-OTHER-KEYS", CL_ORDINARY, NULL, -1, OBJNULL},
@ -1101,7 +1103,6 @@ cl_symbols[] = {
{SYS_ "*IGNORE-EOF-ON-TERMINAL-IO*", SI_SPECIAL, NULL, -1, ECL_NIL},
{SYS_ "*INDENT-FORMATTED-OUTPUT*", SI_SPECIAL, NULL, -1, ECL_NIL},
{SYS_ "*INIT-FUNCTION-PREFIX*", SI_SPECIAL, NULL, -1, ECL_NIL},
{EXT_ "*INTERRUPTS-ENABLED*", EXT_SPECIAL, NULL, 1, ECL_T},
{SYS_ "*KEEP-DEFINITIONS*", SI_SPECIAL, NULL, -1, ECL_T},
{EXT_ "*LOAD-HOOKS*", EXT_SPECIAL, NULL, -1, OBJNULL},
{SYS_ "*LOAD-SEARCH-LIST*", SI_SPECIAL, NULL, -1, ECL_NIL},

3
src/c/symbols_list2.h
View file

@ -74,8 +74,10 @@ cl_symbols[] = {
{"T",NULL},
{SYS_ "UNBOUND","si_unbound"},
{SYS_ "PROTECT-TAG",NULL},
{SYS_ "DUMMY-TAG",NULL},
{SYS_ "*RESTART-CLUSTERS*",NULL},
{SYS_ "*HANDLER-CLUSTERS*",NULL},
{EXT_ "*INTERRUPTS-ENABLED*",NULL},
/* LISP PACKAGE */
{"&ALLOW-OTHER-KEYS",NULL},
@ -1101,7 +1103,6 @@ cl_symbols[] = {
{SYS_ "*IGNORE-EOF-ON-TERMINAL-IO*",NULL},
{SYS_ "*INDENT-FORMATTED-OUTPUT*",NULL},
{SYS_ "*INIT-FUNCTION-PREFIX*",NULL},
{EXT_ "*INTERRUPTS-ENABLED*",NULL},
{SYS_ "*KEEP-DEFINITIONS*",NULL},
{EXT_ "*LOAD-HOOKS*",NULL},
{SYS_ "*LOAD-SEARCH-LIST*",NULL},

7
src/c/threads/barrier.d
View file

@ -143,21 +143,22 @@ mp_barrier_wait(cl_object barrier)
}
ecl_disable_interrupts_env(the_env);
counter = decrement_counter(&barrier->barrier.arrivers_count);
if (counter == 0) {
if (counter == 1) {
print_lock("barrier %p saturated", barrier, barrier);
/* There are (count-1) threads in the queue and we
* are the last one. We thus unblock all threads and
* proceed. */
mp_barrier_unblock(1, barrier);
ecl_enable_interrupts_env(the_env);
mp_barrier_unblock(1, barrier);
output = @':unblocked';
} else if (counter > 0) {
} else if (counter > 1) {
print_lock("barrier %p waiting", barrier, barrier);
ecl_enable_interrupts_env(the_env);
ecl_wait_on(the_env, barrier_wait_condition, barrier);
output = ECL_T;
} else {
print_lock("barrier %p pass-through", barrier, barrier);
ecl_enable_interrupts_env(the_env);
/* Barrier disabled */
output = ECL_NIL;
}

243
src/c/threads/process.d
View file

@ -43,6 +43,16 @@ static pthread_key_t cl_env_key;
extern void ecl_init_env(struct cl_env_struct *env);
#if !defined(WITH___THREAD)
cl_env_ptr
ecl_process_env_unsafe(void)
{
#ifdef ECL_WINDOWS_THREADS
return TlsGetValue(cl_env_key);
#else
return pthread_getspecific(cl_env_key);
#endif
}
cl_env_ptr
ecl_process_env(void)
{
@ -124,24 +134,26 @@ ecl_list_process(cl_object process)
} while (1);
}
/* Must be called with disabled interrupts to prevent race conditions
* in thread_cleanup */
static void
ecl_unlist_process(cl_object process)
{
cl_env_ptr the_env = ecl_process_env();
ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) {
cl_object vector = cl_core.processes;
cl_index i;
for (i = 0; i < vector->vector.fillp; i++) {
if (vector->vector.self.t[i] == process) {
vector->vector.fillp--;
do {
vector->vector.self.t[i] =
vector->vector.self.t[i+1];
} while (++i < vector->vector.fillp);
break;
}
ecl_get_spinlock(the_env, &cl_core.processes_spinlock);
cl_object vector = cl_core.processes;
cl_index i;
for (i = 0; i < vector->vector.fillp; i++) {
if (vector->vector.self.t[i] == process) {
vector->vector.fillp--;
do {
vector->vector.self.t[i] =
vector->vector.self.t[i+1];
} while (++i < vector->vector.fillp);
break;
}
} ECL_WITH_SPINLOCK_END;
}
ecl_giveup_spinlock(&cl_core.processes_spinlock);
}
static cl_object
@ -185,30 +197,33 @@ thread_cleanup(void *aux)
* executed, never use pthread_cancel() to kill a process, but
* rather use the lisp functions mp_interrupt_process() and
* mp_process_kill().
*
* NOTE: to avoid race conditions, this method must be executed
* while process.start_stop_spinlock is held.
*/
cl_object process = (cl_object)aux;
cl_env_ptr env = process->process.env;
/* Block interrupts during the execution of this method */
ECL_WITH_SPINLOCK_BEGIN(env, &process->process.start_stop_spinlock) {
/* The following flags will disable all interrupts. */
AO_store_full((AO_t*)&process->process.phase, ECL_PROCESS_EXITING);
if (env) ecl_disable_interrupts_env(env);
/* The following flags will disable all interrupts. */
AO_store_full((AO_t*)&process->process.phase, ECL_PROCESS_EXITING);
if (env) ecl_disable_interrupts_env(env);
#ifdef HAVE_SIGPROCMASK
/* ...but we might get stray signals. */
{
sigset_t new[1];
sigemptyset(new);
sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]);
pthread_sigmask(SIG_BLOCK, new, NULL);
}
/* ...but we might get stray signals. */
{
sigset_t new[1];
sigemptyset(new);
sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]);
pthread_sigmask(SIG_BLOCK, new, NULL);
}
#endif
process->process.env = NULL;
ecl_unlist_process(process);
mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T);
ecl_set_process_env(NULL);
if (env) _ecl_dealloc_env(env);
AO_store_release((AO_t*)&process->process.phase, ECL_PROCESS_INACTIVE);
} ECL_WITH_SPINLOCK_END;
process->process.env = NULL;
ecl_unlist_process(process);
mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T);
ecl_set_process_env(NULL);
if (env) _ecl_dealloc_env(env);
#ifdef ECL_WINDOWS_THREADS
CloseHandle(process->process.thread);
#endif
AO_store_release((AO_t*)&process->process.phase, ECL_PROCESS_INACTIVE);
}
#ifdef ECL_WINDOWS_THREADS
@ -276,6 +291,7 @@ static DWORD WINAPI thread_entry_point(void *arg)
} ECL_RESTART_CASE_END;
/* This will disable interrupts during the exit
* so that the unwinding is not interrupted. */
ecl_get_spinlock(env, &process->process.start_stop_spinlock);
process->process.phase = ECL_PROCESS_EXITING;
ecl_bds_unwind1(env);
} ECL_CATCH_ALL_END;
@ -286,9 +302,13 @@ static DWORD WINAPI thread_entry_point(void *arg)
*/
#ifdef ECL_WINDOWS_THREADS
thread_cleanup(process);
return 1;
#else
pthread_cleanup_pop(1);
#endif
ecl_giveup_spinlock(&process->process.start_stop_spinlock);
#ifdef ECL_WINDOWS_THREADS
return 1;
#else
return NULL;
#endif
}
@ -390,7 +410,6 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
process->process.env = env;
process->process.phase = ECL_PROCESS_BOOTING;
process->process.thread = current;
ecl_list_process(process);
ecl_init_env(env);
env->cleanup = registered;
@ -399,6 +418,7 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
env->thread_local_bindings = env->bindings_array->vector.self.t;
ecl_enable_interrupts_env(env);
ecl_list_process(process);
/* Activate the barrier so that processes can immediately start waiting. */
mp_barrier_unblock(1, process->process.exit_barrier);
process->process.phase = ECL_PROCESS_ACTIVE;
@ -416,7 +436,10 @@ ecl_release_current_thread(void)
#endif
int cleanup = env->cleanup;
thread_cleanup(env->own_process);
cl_object own_process = env->own_process;
ecl_get_spinlock(env, &own_process->process.start_stop_spinlock);
thread_cleanup(own_process);
ecl_giveup_spinlock(&own_process->process.start_stop_spinlock);
#ifdef GBC_BOEHM
if (cleanup) {
GC_unregister_my_thread();
@ -511,88 +534,96 @@ mp_process_yield(void)
cl_object
mp_process_enable(cl_object process)
{
cl_env_ptr process_env;
int ok;
/* Try to gain exclusive access to the process at the same
* time we ensure that it is inactive. This prevents two
* concurrent calls to process-enable from different threads
* on the same process */
unlikely_if (!AO_compare_and_swap_full((AO_t*)&process->process.phase,
ECL_PROCESS_INACTIVE,
ECL_PROCESS_BOOTING)) {
FEerror("Cannot enable the running process ~A.", 1, process);
}
process->process.parent = mp_current_process();
process->process.trap_fpe_bits =
process->process.parent->process.env->trap_fpe_bits;
ecl_list_process(process);
cl_env_ptr process_env = NULL;
cl_env_ptr the_env = ecl_process_env();
int ok = 0;
ECL_UNWIND_PROTECT_BEGIN(the_env) {
/* Try to gain exclusive access to the process at the same
* time we ensure that it is inactive. This prevents two
* concurrent calls to process-enable from different threads
* on the same process */
unlikely_if (!AO_compare_and_swap_full((AO_t*)&process->process.phase,
ECL_PROCESS_INACTIVE,
ECL_PROCESS_BOOTING)) {
FEerror("Cannot enable the running process ~A.", 1, process);
}
process->process.parent = mp_current_process();
process->process.trap_fpe_bits =
process->process.parent->process.env->trap_fpe_bits;
ecl_list_process(process);
/* Link environment and process together */
process_env = _ecl_alloc_env(ecl_process_env());
process_env->own_process = process;
process->process.env = process_env;
/* Link environment and process together */
process_env = _ecl_alloc_env(the_env);
process_env->own_process = process;
process->process.env = process_env;
ecl_init_env(process_env);
process_env->trap_fpe_bits = process->process.trap_fpe_bits;
process_env->bindings_array = process->process.initial_bindings;
process_env->thread_local_bindings_size =
process_env->bindings_array->vector.dim;
process_env->thread_local_bindings =
process_env->bindings_array->vector.self.t;
ecl_init_env(process_env);
process_env->trap_fpe_bits = process->process.trap_fpe_bits;
process_env->bindings_array = process->process.initial_bindings;
process_env->thread_local_bindings_size =
process_env->bindings_array->vector.dim;
process_env->thread_local_bindings =
process_env->bindings_array->vector.self.t;
/* Activate the barrier so that processes can immediately start waiting. */
mp_barrier_unblock(1, process->process.exit_barrier);
/* Activate the barrier so that processes can immediately start waiting. */
mp_barrier_unblock(1, process->process.exit_barrier);
/* Block the thread with this spinlock until it is ready */
process->process.start_stop_spinlock = ECL_T;
/* Block the thread with this spinlock until it is ready */
process->process.start_stop_spinlock = ECL_T;
ecl_disable_interrupts_env(the_env);
#ifdef ECL_WINDOWS_THREADS
{
HANDLE code;
DWORD threadId;
code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId);
ok = (process->process.thread = code) != NULL;
}
#else
{
int code;
pthread_attr_t pthreadattr;
pthread_attr_init(&pthreadattr);
pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED);
/*
* We launch the thread with the signal mask specified in cl_core.
* The reason is that we might need to block certain signals
* to be processed by the signal handling thread in unixint.d
*/
#ifdef HAVE_SIGPROCMASK
{
sigset_t new, previous;
sigfillset(&new);
pthread_sigmask(SIG_BLOCK, &new, &previous);
code = pthread_create(&process->process.thread, &pthreadattr,
thread_entry_point, process);
pthread_sigmask(SIG_SETMASK, &previous, NULL);
HANDLE code;
DWORD threadId;
code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId);
ok = (process->process.thread = code) != NULL;
}
#else
code = pthread_create(&process->process.thread, &pthreadattr,
thread_entry_point, process);
{
int code;
pthread_attr_t pthreadattr;
pthread_attr_init(&pthreadattr);
pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED);
/*
* We launch the thread with the signal mask specified in cl_core.
* The reason is that we might need to block certain signals
* to be processed by the signal handling thread in unixint.d
*/
#ifdef HAVE_SIGPROCMASK
{
sigset_t new, previous;
sigfillset(&new);
pthread_sigmask(SIG_BLOCK, &new, &previous);
code = pthread_create(&process->process.thread, &pthreadattr,
thread_entry_point, process);
pthread_sigmask(SIG_SETMASK, &previous, NULL);
}
#else
code = pthread_create(&process->process.thread, &pthreadattr,
thread_entry_point, process);
#endif
ok = (code == 0);
}
ok = (code == 0);
}
#endif
if (!ok) {
ecl_unlist_process(process);
/* Disable the barrier and alert possible waiting processes. */
mp_barrier_unblock(3, process->process.exit_barrier,
@':disable', ECL_T);
process->process.phase = ECL_PROCESS_INACTIVE;
process->process.env = NULL;
_ecl_dealloc_env(process_env);
}
/* Unleash the thread */
process->process.start_stop_spinlock = ECL_NIL;
ecl_enable_interrupts_env(the_env);
} ECL_UNWIND_PROTECT_EXIT {
if (!ok) {
/* INV: interrupts are already disabled through unwind-protect */
ecl_unlist_process(process);
/* Disable the barrier and alert possible waiting processes. */
mp_barrier_unblock(3, process->process.exit_barrier,
@':disable', ECL_T);
process->process.phase = ECL_PROCESS_INACTIVE;
process->process.env = NULL;
if(process_env != NULL)
_ecl_dealloc_env(process_env);
}
/* Unleash the thread */
ecl_giveup_spinlock(&process->process.start_stop_spinlock);
} ECL_UNWIND_PROTECT_END;
@(return (ok? process : ECL_NIL));
}

11
src/c/threads/queue.d
View file

@ -34,6 +34,8 @@ void ECL_INLINE
ecl_get_spinlock(cl_env_ptr the_env, cl_object *lock)
{
cl_object own_process = the_env->own_process;
if(*lock == own_process)
return;
while (!AO_compare_and_swap_full((AO_t*)lock, (AO_t)ECL_NIL,
(AO_t)own_process)) {
ecl_process_yield();
@ -336,6 +338,7 @@ ecl_wakeup_waiters(cl_env_ptr the_env, cl_object q, int flags)
cl_object *tail, l;
for (tail = &q->queue.list; (l = *tail) != ECL_NIL; ) {
cl_object p = ECL_CONS_CAR(l);
ecl_get_spinlock(the_env, &p->process.start_stop_spinlock);
if (p->process.phase == ECL_PROCESS_INACTIVE ||
p->process.phase == ECL_PROCESS_EXITING) {
print_lock("removing %p", q, p);
@ -349,15 +352,19 @@ ecl_wakeup_waiters(cl_env_ptr the_env, cl_object q, int flags)
*tail = ECL_CONS_CDR(l);
tail = &ECL_CONS_CDR(l);
if (flags & ECL_WAKEUP_KILL)
mp_process_kill(p);
ecl_interrupt_process(p, @'mp::exit-process');
else
ecl_wakeup_process(p);
if (!(flags & ECL_WAKEUP_ALL))
if (!(flags & ECL_WAKEUP_ALL)) {
ecl_giveup_spinlock(&p->process.start_stop_spinlock);
break;
}
}
ecl_giveup_spinlock(&p->process.start_stop_spinlock);
}
}
ecl_giveup_spinlock(&q->queue.spinlock);
ecl_enable_interrupts_env(the_env);
ecl_process_yield();
}

2
src/c/unixfsys.d
View file

@ -834,8 +834,8 @@ list_directory(cl_object base_dir, cl_object text_mask, cl_object pathname_mask,
# endif /* !ECL_MS_WINDOWS_HOST */
#endif /* !HAVE_DIRENT_H */
ecl_enable_interrupts();
OUTPUT:
ecl_enable_interrupts();
return cl_nreverse(out);
}

102
src/c/unixint.d
View file

@ -367,28 +367,52 @@ si_handle_signal(cl_object signal_code, cl_object process)
static void
handle_all_queued(cl_env_ptr env)
{
while (env->pending_interrupt != ECL_NIL) {
while (env->interrupt_struct->pending_interrupt != ECL_NIL) {
handle_signal_now(pop_signal(env), env->own_process);
}
}
static void
handle_all_queued_interrupt_safe(cl_env_ptr env)
{
/* We have to save and later restore thread-local variables to
* ensure that they don't get overwritten by the interrupting
* code */
cl_object fun = env->function;
cl_index nvalues = env->nvalues;
cl_object* values = ecl_alloc_atomic(ECL_MULTIPLE_VALUES_LIMIT*sizeof(cl_object));
memcpy(values, env->values, ECL_MULTIPLE_VALUES_LIMIT*sizeof(cl_object));
cl_object big_register[3];
memcpy(big_register, env->big_register, 3*sizeof(cl_object));
/* We might have been interrupted while we push/pop in the
* stack. Increasing env->stack_top ensures that we don't
* overwrite the topmost stack value. */
env->stack_top++;
handle_all_queued(env);
env->stack_top--;
memcpy(env->big_register, big_register, 3*sizeof(cl_object));
memcpy(env->values, values, ECL_MULTIPLE_VALUES_LIMIT*sizeof(cl_object));
env->nvalues = nvalues;
env->function = fun;
}
static void
queue_signal(cl_env_ptr env, cl_object code, int allocate)
{
ECL_WITH_SPINLOCK_BEGIN(env, &env->signal_queue_spinlock) {
ECL_WITH_SPINLOCK_BEGIN(ecl_process_env(), &env->interrupt_struct->signal_queue_spinlock) {
cl_object record;
if (allocate) {
record = ecl_list1(ECL_NIL);
} else {
record = env->signal_queue;
record = env->interrupt_struct->signal_queue;
if (record != ECL_NIL) {
env->signal_queue = ECL_CONS_CDR(record);
env->interrupt_struct->signal_queue = ECL_CONS_CDR(record);
}
}
if (record != ECL_NIL) {
ECL_RPLACA(record, code);
env->pending_interrupt =
ecl_nconc(env->pending_interrupt,
env->interrupt_struct->pending_interrupt =
ecl_nconc(env->interrupt_struct->pending_interrupt,
record);
}
} ECL_WITH_SPINLOCK_END;
@ -398,17 +422,18 @@ static cl_object
pop_signal(cl_env_ptr env)
{
cl_object record, value;
if (env->pending_interrupt == ECL_NIL) {
return ECL_NIL;
}
ECL_WITH_SPINLOCK_BEGIN(env, &env->signal_queue_spinlock) {
record = env->pending_interrupt;
value = ECL_CONS_CAR(record);
env->pending_interrupt = ECL_CONS_CDR(record);
/* Save some conses for future use, to avoid allocating */
if (ECL_SYMBOLP(value) || ECL_FIXNUMP(value)) {
ECL_RPLACD(record, env->signal_queue);
env->signal_queue = record;
ECL_WITH_SPINLOCK_BEGIN(env, &env->interrupt_struct->signal_queue_spinlock) {
if (env->interrupt_struct->pending_interrupt == ECL_NIL) {
value = ECL_NIL;
} else {
record = env->interrupt_struct->pending_interrupt;
value = ECL_CONS_CAR(record);
env->interrupt_struct->pending_interrupt = ECL_CONS_CDR(record);
/* Save some conses for future use, to avoid allocating */
if (ECL_SYMBOLP(value) || ECL_FIXNUMP(value)) {
ECL_RPLACD(record, env->interrupt_struct->signal_queue);
env->interrupt_struct->signal_queue = record;
}
}
} ECL_WITH_SPINLOCK_END;
return value;
@ -599,12 +624,12 @@ handler_fn_prototype(process_interrupt_handler, int sig, siginfo_t *siginfo, voi
the_env = ecl_process_env();
if (zombie_process(the_env))
return;
if (!Null(the_env->pending_interrupt)) {
if (!Null(the_env->interrupt_struct->pending_interrupt)) {
if (interrupts_disabled_by_C(the_env)) {
set_guard_page(the_env);
} else if (!interrupts_disabled_by_lisp(the_env)) {
unblock_signal(the_env, sig);
handle_all_queued(the_env);
handle_all_queued_interrupt_safe(the_env);
}
}
errno = old_errno;
@ -712,6 +737,12 @@ handler_fn_prototype(sigsegv_handler, int sig, siginfo_t *info, void *aux)
"also known as 'bus or segmentation fault'.\n"
";;; Jumping to the outermost toplevel prompt\n"
";;;\n\n";
static const char *interrupt_msg =
"\n;;;\n;;; Internal error:\n"
";;; Detected write access to the environment while "
"interrupts were disabled. Usually this is caused by "
"a missing call to ecl_enable_interrupts.\n"
";;;\n\n";
cl_env_ptr the_env;
reinstall_signal(sig, sigsegv_handler);
/* The lisp environment might not be installed. */
@ -723,15 +754,23 @@ handler_fn_prototype(sigsegv_handler, int sig, siginfo_t *info, void *aux)
return;
#if defined(SA_SIGINFO) && !defined(NACL)
# if defined(ECL_USE_MPROTECT)
/* We access the environment when it was protected. That
* means there was a pending signal. */
if (((char*)the_env <= (char*)info->si_addr) &&
((char*)info->si_addr <= (char*)(the_env+1)))
/* We access disable_interrupts when the environment was
* protected. That means there was a pending signal. */
if (((char*)&the_env->disable_interrupts <= (char*)info->si_addr) &&
((char*)info->si_addr < (char*)(&the_env->disable_interrupts+1)))
{
mprotect(the_env, sizeof(*the_env), PROT_READ | PROT_WRITE);
the_env->disable_interrupts = 0;
unblock_signal(the_env, sig);
handle_all_queued(the_env);
handle_all_queued_interrupt_safe(the_env);
return;
} else if (the_env->disable_interrupts &&
((char*)(&the_env->disable_interrupts+1) <= (char*)info->si_addr) &&
((char*)info->si_addr < (char*)(the_env+1))) {
mprotect(the_env, sizeof(*the_env), PROT_READ | PROT_WRITE);
the_env->disable_interrupts = 0;
unblock_signal(the_env, sig);
ecl_unrecoverable_error(the_env, interrupt_msg);
return;
}
# endif /* ECL_USE_MPROTECT */
@ -784,7 +823,8 @@ si_check_pending_interrupts(void)
void
ecl_check_pending_interrupts(cl_env_ptr env)
{
handle_all_queued(env);
if(env->interrupt_struct->pending_interrupt != ECL_NIL)
handle_all_queued_interrupt_safe(env);
}
static cl_object
@ -943,7 +983,7 @@ do_interrupt_thread(cl_object process)
# ifndef ECL_USE_GUARD_PAGE
# error "Cannot implement ecl_interrupt_process without guard pages"
# endif
HANDLE thread = (HANDLE)process->process.thread;
HANDLE thread = process->process.thread;
CONTEXT context;
void *trap_address = process->process.env;
DWORD guard = PAGE_GUARD | PAGE_READWRITE;
@ -1018,7 +1058,7 @@ void
ecl_wakeup_process(cl_object process)
{
# ifdef ECL_WINDOWS_THREADS
HANDLE thread = (HANDLE)process->process.thread;
HANDLE thread = process->process.thread;
if (!QueueUserAPC(wakeup_noop, thread, 0)) {
FEwin32_error("Unable to queue APC call to thread ~A",
1, process);
@ -1045,14 +1085,10 @@ _ecl_w32_exception_filter(struct _EXCEPTION_POINTERS* ep)
case STATUS_GUARD_PAGE_VIOLATION: {
cl_object process = the_env->own_process;
if (!Null(process->process.interrupt)) {
cl_object signal = pop_signal(the_env);
process->process.interrupt = ECL_NIL;
while (signal != ECL_NIL && signal) {
handle_signal_now(signal, the_env->own_process);
signal = pop_signal(the_env);
}
return EXCEPTION_CONTINUE_EXECUTION;
handle_all_queued_interrupt_safe(the_env);
}
return EXCEPTION_CONTINUE_EXECUTION;
}
/* Catch all arithmetic exceptions */
case EXCEPTION_INT_DIVIDE_BY_ZERO:

3
src/cmp/cmpblock.lsp
View file

@ -60,7 +60,8 @@
(let ((env-lvl *env-lvl*))
(wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var)
(wt-nl "if (ecl_frs_push(cl_env_copy," blk-var ")!=0) {")
(wt-nl "ecl_frs_push(cl_env_copy," blk-var ");")
(wt-nl "if (__ecl_frs_push_result!=0) {")
(let ((*unwind-exit* (cons 'FRAME *unwind-exit*)))
(unwind-exit 'VALUES)
(wt-nl "} else {")

9
src/cmp/cmpcatch.lsp
View file

@ -32,12 +32,14 @@
(*unwind-exit* (cons 'FRAME *unwind-exit*)))
(if (member new-destination '(TRASH VALUES))
(progn
(wt-nl "if (ecl_frs_push(cl_env_copy," 'VALUE0 ")==0) {")
(wt-nl "ecl_frs_push(cl_env_copy," 'VALUE0 ");")
(wt-nl "if (__ecl_frs_push_result==0) {")
(wt-comment "BEGIN CATCH ~A" code)
(with-indentation
(c2expr* body)))
(progn
(wt-nl "if (ecl_frs_push(cl_env_copy," 'VALUE0 ")) {")
(wt-nl "ecl_frs_push(cl_env_copy," 'VALUE0 ");")
(wt-nl "if (__ecl_frs_push_result) {")
(wt-comment "BEGIN CATCH ~A" code)
(with-indentation
(with-exit-label (label)
@ -75,7 +77,8 @@
(wt-nl "ecl_frame_ptr next_fr;")
;; Here we compile the form which is protected. When this form
;; is aborted, it continues at the ecl_frs_pop() with unwinding=TRUE.
(wt-nl "if (ecl_frs_push(cl_env_copy,ECL_PROTECT_TAG)) {")
(wt-nl "ecl_frs_push(cl_env_copy,ECL_PROTECT_TAG);")
(wt-nl "if (__ecl_frs_push_result) {")
(wt-nl " unwinding = TRUE; next_fr=cl_env_copy->nlj_fr;")
(wt-nl "} else {")
(let ((*unwind-exit* (cons 'FRAME *unwind-exit*))

3
src/cmp/cmptag.lsp
View file

@ -151,7 +151,8 @@
(maybe-open-inline-block)
(wt-nl "cl_object " tag-loc ";"))
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc)
(wt-nl "if (ecl_frs_push(cl_env_copy," tag-loc ")) {")
(wt-nl "ecl_frs_push(cl_env_copy," tag-loc ");")
(wt-nl "if (__ecl_frs_push_result) {")
;; Allocate labels.
(dolist (tag body)
(when (and (tag-p tag) (plusp (tag-ref tag)))

6
src/doc/new-doc/user-guide/embedding.txi
View file

@ -43,7 +43,7 @@ This is a set of three macros that create an @code{UNWIND-PROTECT} region that p
(return nil)))
@end verbatim
As explained in @code{CL_UNWIND_PROTECT},it is normally advisable to set up an unwind-protect frame to avoid the embedded lisp code to perform arbitary transfers of control.
As explained in @code{CL_UNWIND_PROTECT},it is normally advisable to set up an unwind-protect frame to avoid the embedded lisp code to perform arbitrary transfers of control.
@subsubheading See also
@code{CL_UNWIND_PROTECT}
@ -78,7 +78,7 @@ Create a protected region.
@end verbatim
@subsubheading Description
When embedding ECL it is normally advisable to set up an unwind-protect frame to avoid the embedded lisp code to perform arbitary transfers of control. Furthermore, the unwind protect form will be used in at least in the following ocasions:
When embedding ECL it is normally advisable to set up an unwind-protect frame to avoid the embedded lisp code to perform arbitrary transfers of control. Furthermore, the unwind protect form will be used in at least in the following occasions:
@itemize
@item In a normal program exit, caused by @code{ext:quit}, ECL unwinds up to the outermost frame, which may be an @code{CL_CATCH_ALL} or @code{CL_UNWIND_PROTECT} macro.
@ -190,7 +190,7 @@ This macro clears all pending interrupts.
Postpone handling of signals and exceptions.
@subsubheading Description
This macro sets a thread-local flag indicating that all received signals should be queued for later processing.
This macro sets a thread-local flag indicating that all received signals should be queued for later processing. Note that it is not possible to execute lisp code while interrupts are disabled in this way. For this purpose, use the @code{ext:without-interrupts} macro. Every call to @code{ecl_disable_interrupts} must be followed by a corresponding call to @code{ecl_enable_interrupts}, else race conditions will appear.
@subsubheading See also
@code{ecl_enable_interrupts} and @code{ecl_clear_interrupts}.

34
src/h/ecl-atomic-ops.h Normal file
View file

@ -0,0 +1,34 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/*
ecl-atomic-ops.h -- Wrapper around libatomic_ops functions
*/
/*
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
#ifndef ECL_ATOMIC_OPS_H
#define ECL_ATOMIC_OPS_H
#ifdef ECL_THREADS
# define AO_REQUIRE_CAS
# ifdef ECL_LIBATOMIC_OPS_H
# include <ecl/atomic_ops.h>
# else
# include <atomic_ops.h>
# endif
#else
# define AO_load(x) (x)
# define AO_store(x,y) ((x)=(y))
# define AO_nop_full()
#endif
#endif /* ECL_ATOMIC_OPS_H */

24
src/h/external.h
View file

@ -99,12 +99,15 @@ struct cl_env_struct {
/* ... arithmetics ... */
/* Note: if you change the size of these registers, change also
BIGNUM_REGISTER_SIZE in config.h */
/* FIXME: actually use BIGNUM_REGISTER_SIZE; Also fix
handle_all_queued_interrupt_safe in unixint.d */
cl_object big_register[3];
cl_object own_process;
cl_object pending_interrupt;
cl_object signal_queue;
cl_object signal_queue_spinlock;
/* The objects in this struct need to be writeable from a
different thread, if environment is write-protected by
mprotect. Hence they have to be allocated seperately. */
struct ecl_interrupt_struct *interrupt_struct;
void *default_sigmask;
/* The following is a hash table for caching invocations of
@ -145,6 +148,12 @@ struct cl_env_struct {
#endif
};
struct ecl_interrupt_struct {
cl_object pending_interrupt;
cl_object signal_queue;
cl_object signal_queue_spinlock;
};
#ifndef __GNUC__
#define __attribute__(x)
#endif
@ -152,14 +161,17 @@ struct cl_env_struct {
# ifdef WITH___THREAD
# define cl_env (*cl_env_p)
# define ecl_process_env() cl_env_p
# define ecl_process_env_unsafe() cl_env_p
extern __thread cl_env_ptr cl_env_p;
# else
# define cl_env (*ecl_process_env())
extern ECL_API cl_env_ptr ecl_process_env(void) __attribute__((const));
extern ECL_API cl_env_ptr ecl_process_env_unsafe(void) __attribute__((const));
# endif
#else
# define cl_env (*cl_env_p)
# define ecl_process_env() cl_env_p
# define ecl_process_env_unsafe() cl_env_p
extern ECL_API cl_env_ptr cl_env_p;
#endif
@ -1869,7 +1881,7 @@ extern ECL_API cl_object si_copy_file(cl_object orig, cl_object end);
#define ecl_disable_interrupts_env(env) ((env)->disable_interrupts=1)
#define ecl_enable_interrupts_env(env) (((env)->disable_interrupts^=1) && (ecl_check_pending_interrupts(env),0))
#endif
#define ecl_clear_interrupts_env(env) ((env)->pendinginterrupts=0)
#define ecl_clear_interrupts_env(env) ((env)->interrupt_struct->pending_interrupt=ECL_NIL)
#define ecl_clear_interrupts() ecl_clear_interrupts(&cl_env)
#define ecl_disable_interrupts() ecl_disable_interrupts_env(&cl_env)
#define ecl_enable_interrupts() ecl_enable_interrupts_env(&cl_env)
@ -1899,10 +1911,10 @@ extern ECL_API cl_object si_waitpid(cl_object pid, cl_object wait);
extern ECL_API cl_object si_killpid(cl_object pid, cl_object signal);
extern ECL_API cl_object si_run_program_inner
(cl_object command, cl_object argv, cl_object environ);
(cl_object command, cl_object argv, cl_object environment);
extern ECL_API cl_object si_spawn_subprocess
(cl_object command, cl_object argv, cl_object environ,
(cl_object command, cl_object argv, cl_object environment,
cl_object input, cl_object output, cl_object error);

63
src/h/internal.h
View file

@ -369,23 +369,26 @@ extern void cl_write_object(cl_object x, cl_object stream);
ECL_WITH_LOCK_BEGIN(the_env, cl_core.global_lock)
# define ECL_WITH_GLOBAL_LOCK_END \
ECL_WITH_LOCK_END
# define ECL_WITH_LOCK_BEGIN(the_env,lock) { \
const cl_env_ptr __ecl_the_env = the_env; \
const cl_object __ecl_the_lock = lock; \
ecl_disable_interrupts_env(the_env); \
mp_get_lock_wait(__ecl_the_lock); \
ECL_UNWIND_PROTECT_BEGIN(__ecl_the_env); \
# define ECL_WITH_LOCK_BEGIN(the_env,lock) { \
const cl_env_ptr __ecl_the_env = the_env; \
const cl_object __ecl_the_lock = lock; \
ecl_disable_interrupts_env(__ecl_the_env); \
mp_get_lock_wait(__ecl_the_lock); \
ECL_UNWIND_PROTECT_BEGIN(__ecl_the_env); \
ecl_enable_interrupts_env(__ecl_the_env);
# define ECL_WITH_LOCK_END \
ECL_UNWIND_PROTECT_EXIT { \
mp_giveup_lock(__ecl_the_lock); \
# define ECL_WITH_LOCK_END \
ECL_UNWIND_PROTECT_EXIT { \
mp_giveup_lock(__ecl_the_lock); \
} ECL_UNWIND_PROTECT_END; }
# define ECL_WITH_SPINLOCK_BEGIN(the_env,lock) { \
const cl_env_ptr __ecl_the_env = (the_env); \
cl_object *__ecl_the_lock = (lock); \
# define ECL_WITH_SPINLOCK_BEGIN(the_env,lock) { \
const cl_env_ptr __ecl_the_env = (the_env); \
cl_object *__ecl_the_lock = (lock); \
ECL_UNWIND_PROTECT_BEGIN(__ecl_the_env); \
ecl_get_spinlock(__ecl_the_env, __ecl_the_lock);
# define ECL_WITH_SPINLOCK_END \
ecl_giveup_spinlock(__ecl_the_lock); }
# define ECL_WITH_SPINLOCK_END \
ECL_UNWIND_PROTECT_EXIT { \
ecl_giveup_spinlock(__ecl_the_lock); \
} ECL_UNWIND_PROTECT_END; }
#else
# define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env)
# define ECL_WITH_GLOBAL_LOCK_END
@ -398,18 +401,20 @@ extern void cl_write_object(cl_object x, cl_object stream);
#ifdef ECL_RWLOCK
# define ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { \
const cl_env_ptr __ecl_pack_env = the_env; \
ecl_disable_interrupts_env(__ecl_pack_env); \
ecl_bds_bind(__ecl_pack_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); \
mp_get_rwlock_read_wait(cl_core.global_env_lock);
# define ECL_WITH_GLOBAL_ENV_RDLOCK_END \
mp_giveup_rwlock_read(cl_core.global_env_lock); \
ecl_enable_interrupts_env(__ecl_pack_env); }
ecl_bds_unwind1(__ecl_pack_env); \
ecl_check_pending_interrupts(__ecl_pack_env); }
# define ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { \
const cl_env_ptr __ecl_pack_env = the_env; \
ecl_disable_interrupts_env(__ecl_pack_env); \
ecl_bds_bind(__ecl_pack_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); \
mp_get_rwlock_write_wait(cl_core.global_env_lock);
# define ECL_WITH_GLOBAL_ENV_WRLOCK_END \
mp_giveup_rwlock_write(cl_core.global_env_lock); \
ecl_enable_interrupts_env(__ecl_pack_env); }
ecl_bds_unwind1(__ecl_pack_env); \
ecl_check_pending_interrupts(__ecl_pack_env); }
#else
# define ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env)
# define ECL_WITH_GLOBAL_ENV_RDLOCK_END
@ -417,17 +422,7 @@ extern void cl_write_object(cl_object x, cl_object stream);
# define ECL_WITH_GLOBAL_ENV_WRLOCK_END
#endif /* ECL_RWLOCK */
#ifdef ECL_THREADS
# define AO_REQUIRE_CAS
# ifdef ECL_LIBATOMIC_OPS_H
# include <ecl/atomic_ops.h>
# else
# include <atomic_ops.h>
# endif
#else
# define AO_load(x) (x)
# define AO_store(x,y) ((x)=(y))
#endif
#include <ecl/ecl-atomic-ops.h>
/* read.d */
#ifdef ECL_UNICODE
@ -527,6 +522,16 @@ extern cl_object mp_get_rwlock_write_wait(cl_object lock);
extern void ecl_interrupt_process(cl_object process, cl_object function);
/* disabling interrupts on the lisp side */
#define ECL_WITHOUT_INTERRUPTS_BEGIN(the_env) do { \
cl_env_ptr __the_env = (the_env); \
ecl_bds_bind(__the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL);
#define ECL_WITHOUT_INTERRUPTS_END \
ecl_bds_unwind1(__the_env); \
ecl_check_pending_interrupts(__the_env); } while(0)
/* unixsys.d */
/* Some old BSD systems don't have WCONTINUED / WIFCONTINUED */

10
src/h/object.h
View file

@ -246,8 +246,10 @@ enum ecl_stype { /* symbol type */
#define ECL_T ((cl_object)(cl_symbols+1))
#define ECL_UNBOUND ((cl_object)(cl_symbols+2))
#define ECL_PROTECT_TAG ((cl_object)(cl_symbols+3))
#define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+4))
#define ECL_HANDLER_CLUSTERS ((cl_object)(cl_symbols+5))
#define ECL_DUMMY_TAG ((cl_object)(cl_symbols+4))
#define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+5))
#define ECL_HANDLER_CLUSTERS ((cl_object)(cl_symbols+6))
#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+7))
#define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS))
struct ecl_symbol {
@ -883,7 +885,11 @@ struct ecl_process {
cl_object queue_record;
cl_object start_stop_spinlock;
cl_index phase;
#ifdef ECL_WINDOWS_THREADS
HANDLE thread;
#else
pthread_t thread;
#endif
int trap_fpe_bits;
};

43
src/h/stack-resize.h Normal file
View file

@ -0,0 +1,43 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/*
internal.h -- safe stack resizing
*/
/*
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
#ifndef ECL_STACK_RESIZE_H
#define ECL_STACK_RESIZE_H
/* We can't block interrupts with ecl_disable_interrupts() and write
* in the thread local environment if we use fast interrupt dispatch
* via mprotect(), so we have to use sigprocmask instead. No
* performance problems, since this is only used for stack
* resizing. */
#if defined(ECL_THREADS) && defined(ECL_USE_MPROTECT)
# ifdef HAVE_SIGPROCMASK
# include <signal.h>
# define ECL_STACK_RESIZE_DISABLE_INTERRUPTS(the_env) \
sigset_t __sigset_new, __sigset_previous; \
sigfillset(&__sigset_new); \
pthread_sigmask(SIG_BLOCK, &__sigset_new, &__sigset_previous)
# define ECL_STACK_RESIZE_ENABLE_INTERRUPTS(the_env) \
pthread_sigmask(SIG_SETMASK, &__sigset_previous, NULL)
# else
# error "Can't protect stack resizing from interrupts without sigprocmask. Either build ECL without mprotect() or live with possible race conditions."
# endif /* HAVE_SIGPROCMASK */
#else
# define ECL_STACK_RESIZE_DISABLE_INTERRUPTS(the_env) ecl_disable_interrupts_env(the_env);
# define ECL_STACK_RESIZE_ENABLE_INTERRUPTS(the_env) ecl_enable_interrupts_env(env);
# endif /* ECL_THREADS && ECL_USE_MPROTECT */
#endif /* ECL_STACK_RESIZE_H */

164
src/h/stacks.h
View file

@ -17,6 +17,11 @@
See file '../Copyright' for full details.
*/
#ifndef ECL_STACKS_H
#define ECL_STACKS_H
#include <ecl/ecl-atomic-ops.h>
#ifdef __cplusplus
extern "C" {
#endif
@ -33,6 +38,41 @@ extern "C" {
if (ecl_unlikely((char*)(&var) >= (env)->cs_limit)) ecl_cs_overflow()
#endif
/*********************************************************
* INTERRUPT SAFE STACK MANIPULATIONS
*
* The requirement for interruptible threads puts major
* restrictions on the implementation of stack push/pop and unwind
* routines. There are two principle requirements to be fulfilled:
* The code which is executed during the interrupt must not
* overwrite stack values (1) and it must be able to safely call stack
* unwind functions (2).
* The first requirement can be met in two distinct ways:
* - Ordering the manipulations of the stack pointer and of the
* stack itself in the right manner. This means, when pushing in
* the stack first increase the stack pointer and then write the
* value and the other way round for popping from the stack. This
* method has the drawback that it requires insertions of
* memory barriers on modern processors, possibly impacting
* performance.
* - Avoid overwriting stack values in the interrupt signal
* handler. This can be achieved by either increasing the stack
* pointer temporarily during the execution of the interrupt code
* or by saving/restoring the topmost stack value. However due to
* the second requirement, this simple method is only possible
* for the arguments stack.
* The second requirement requires the stack to be in a consistent
* state during the interrupt. The easiest solution would be to
* disable interrupts during stack manipulations. Because of the
* mprotect()-mechanism for fast interrupt dispatch, which does not
* allow writes in the thread-local environment while interrupts
* are disabled, this is unfortunately not possible. The solution
* adopted for this case (bindings and frame stack) is to push a
* dummy tag/symbol in the stack before any other manipulations are
* done. This dummy tag/symbol will then be ignored while
* unwinding.
*/
/**************
* BIND STACK
**************/
@ -76,18 +116,36 @@ static inline void ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v)
ecl_bds_bind(env,s,v);
} else {
location = env->thread_local_bindings + index;
slot = ++env->bds_top;
if (slot >= env->bds_limit) slot = ecl_bds_overflow();
slot = env->bds_top+1;
if (slot >= env->bds_limit){
slot = ecl_bds_overflow();
slot->symbol = ECL_DUMMY_TAG;
} else {
/* First, we push a dummy symbol in the stack to
* prevent segfaults when we are interrupted with a
* call to ecl_bds_unwind. */
slot->symbol = ECL_DUMMY_TAG;
AO_nop_full();
++env->bds_top;
}
AO_nop_full();
/* Then we disable interrupts to ensure that
* ecl_bds_unwind doesn't overwrite the symbol with
* some random value. */
ecl_disable_interrupts_env(env);
slot->symbol = s;
slot->value = *location;
*location = v;
ecl_enable_interrupts_env(env);
}
# else
slot = ++env->bds_top;
if (slot >= env->bds_limit) slot = ecl_bds_overflow();
ecl_disable_interrupts_env(env);
slot->symbol = s;
slot->value = s->symbol.value;
s->symbol.value = v;
ecl_enable_interrupts_env(env);
# endif /* !ECL_THREADS */
}
@ -101,30 +159,42 @@ static inline void ecl_bds_push_inl(cl_env_ptr env, cl_object s)
ecl_bds_push(env, s);
} else {
location = env->thread_local_bindings + index;
slot = ++env->bds_top;
if (slot >= env->bds_limit) slot = ecl_bds_overflow();
slot = env->bds_top+1;
if (slot >= env->bds_limit){
slot = ecl_bds_overflow();
slot->symbol = ECL_DUMMY_TAG;
} else {
slot->symbol = ECL_DUMMY_TAG;
AO_nop_full();
++env->bds_top;
}
AO_nop_full();
ecl_disable_interrupts_env(env);
slot->symbol = s;
slot->value = *location;
if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value;
ecl_enable_interrupts_env(env);
}
# else
slot = ++env->bds_top;
if (slot >= env->bds_limit) slot = ecl_bds_overflow();
ecl_disable_interrupts_env(env);
slot->symbol = s;
slot->value = s->symbol.value;
ecl_enable_interrupts_env(env);
# endif /* !ECL_THREADS */
}
static inline void ecl_bds_unwind1_inl(cl_env_ptr env)
{
ecl_bds_ptr slot = env->bds_top--;
cl_object s = slot->symbol;
cl_object s = env->bds_top->symbol;
# ifdef ECL_THREADS
cl_object *location = env->thread_local_bindings + s->symbol.binding;
*location = slot->value;
*location = env->bds_top->value;
# else
s->symbol.value = slot->value;
s->symbol.value = env->bds_top->value;
# endif
--env->bds_top;
}
# ifdef ECL_THREADS
@ -154,21 +224,27 @@ static inline cl_object *ecl_bds_ref_inl(cl_env_ptr env, cl_object s)
# define ecl_bds_unwind1 ecl_bds_unwind1_inl
#else /* !__GNUC__ */
# ifndef ECL_THREADS
# define ecl_bds_bind(env,sym,val) do { \
const cl_env_ptr env_copy = (env); \
const cl_object s = (sym); \
const cl_object v = (val); \
ecl_bds_check(env_copy); \
(++(env_copy->bds_top))->symbol = s, \
env_copy->bds_top->value = s->symbol.value; \
s->symbol.value = v; } while (0)
# define ecl_bds_bind(env,sym,val) do { \
const cl_env_ptr env_copy = (env); \
const cl_object s = (sym); \
const cl_object v = (val); \
ecl_bds_check(env_copy); \
ecl_bds_ptr slot = ++(env_copy->bds_top); \
ecl_disable_interrupts_env(env_copy); \
slot->symbol = s; \
slot->value = s->symbol.value; \
s->symbol.value = v; \
ecl_enable_interrupts_env(env_copy); } while (0)
# define ecl_bds_push(env,sym) do { \
const cl_env_ptr env_copy = (env); \
const cl_object s = (sym); \
const cl_object v = s->symbol.value; \
ecl_bds_check(env_copy); \
(++(env_copy->bds_top))->symbol = s, \
env_copy->bds_top->value = s->symbol.value; } while (0);
const cl_env_ptr env_copy = (env); \
const cl_object s = (sym); \
const cl_object v = s->symbol.value; \
ecl_bds_check(env_copy); \
ecl_bds_ptr slot = ++(env_copy->bds_top); \
ecl_disable_interrupts_env(env_copy); \
slot->symbol = s; \
slot->value = s->symbol.value; \
ecl_enable_interrupts_env(env_copy); } while (0);
# define ecl_bds_unwind1(env) do { \
const cl_env_ptr env_copy = (env); \
const cl_object s = env_copy->bds_top->symbol; \
@ -238,7 +314,13 @@ typedef struct ecl_frame {
} *ecl_frame_ptr;
extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_object);
#define ecl_frs_push(env,val) ecl_setjmp(_ecl_frs_push(env,val)->frs_jmpbuf)
#define ecl_frs_push(env,val) \
ecl_frame_ptr __frame = _ecl_frs_push(env,val); \
ecl_disable_interrupts_env(env); \
int __ecl_frs_push_result = ecl_setjmp(__frame->frs_jmpbuf); \
__frame->frs_val = val; \
ecl_enable_interrupts_env(env)
#define ecl_frs_pop(env) ((env)->frs_top--)
/*******************
@ -334,8 +416,8 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje
if (ecl_unlikely(__new_top >= __env->stack_limit)) { \
__new_top = ecl_stack_grow(__env); \
} \
*__new_top = (o); \
__env->stack_top = __new_top+1; } while (0)
__env->stack_top = __new_top+1; \
*__new_top = (o); } while (0)
#define ECL_STACK_POP_UNSAFE(env) *(--((env)->stack_top))
@ -385,17 +467,21 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje
bool __unwinding; ecl_frame_ptr __next_fr; \
const cl_env_ptr __the_env = (the_env); \
cl_index __nr; \
if (ecl_frs_push(__the_env,ECL_PROTECT_TAG)) { \
ecl_frs_push(__the_env,ECL_PROTECT_TAG); \
if (__ecl_frs_push_result) { \
__unwinding=1; __next_fr=__the_env->nlj_fr; \
} else {
#define ECL_UNWIND_PROTECT_EXIT \
__unwinding=0; } \
ecl_bds_bind(__the_env,ECL_INTERRUPTS_ENABLED,ECL_NIL); \
ecl_frs_pop(__the_env); \
__nr = ecl_stack_push_values(__the_env);
#define ECL_UNWIND_PROTECT_END \
#define ECL_UNWIND_PROTECT_END \
ecl_stack_pop_values(__the_env,__nr); \
ecl_bds_unwind1(__the_env); \
ecl_check_pending_interrupts(__the_env); \
if (__unwinding) ecl_unwind(__the_env,__next_fr); } while(0)
#define ECL_NEW_FRAME_ID(env) ecl_make_fixnum(env->frame_id++)
@ -403,14 +489,16 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje
#define ECL_BLOCK_BEGIN(the_env,id) do { \
const cl_object __id = ECL_NEW_FRAME_ID(the_env); \
const cl_env_ptr __the_env = (the_env); \
if (ecl_frs_push(__the_env,__id) == 0)
ecl_frs_push(__the_env,__id); \
if (__ecl_frs_push_result == 0)
#define ECL_BLOCK_END \
ecl_frs_pop(__the_env); } while(0)
#define ECL_CATCH_BEGIN(the_env,tag) do { \
const cl_env_ptr __the_env = (the_env); \
if (ecl_frs_push(__the_env,tag) == 0) {
ecl_frs_push(__the_env,tag); \
if (__ecl_frs_push_result == 0) {
#define ECL_CATCH_END } \
ecl_frs_pop(__the_env); } while (0)
@ -420,7 +508,8 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje
const cl_object __ecl_tag = ecl_list1(names); \
ecl_bds_bind(__the_env, ECL_RESTART_CLUSTERS, \
si_bind_simple_restarts(__ecl_tag, names)); \
if (ecl_frs_push(__the_env,__ecl_tag) == 0) {
ecl_frs_push(__the_env,__ecl_tag); \
if (__ecl_frs_push_result == 0) {
#define ECL_RESTART_CASE(code, args) \
} else if (__the_env->values[0] == ecl_make_fixnum(code)) { \
@ -436,7 +525,8 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje
const cl_object __ecl_tag = ecl_list1(names); \
ecl_bds_bind(__the_env, ECL_HANDLER_CLUSTERS, \
si_bind_simple_handlers(__ecl_tag, names)); \
if (ecl_frs_push(__the_env,__ecl_tag) == 0) {
ecl_frs_push(__the_env,__ecl_tag); \
if (__ecl_frs_push_result == 0) {
#define ECL_HANDLER_CASE(code, args) \
} else if (__the_env->values[0] == ecl_make_fixnum(code)) { \
@ -452,16 +542,18 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje
const cl_env_ptr __the_env = (the_env); \
_try { \
const cl_env_ptr __the_env = (the_env); \
if (ecl_frs_push(__the_env,ECL_PROTECT_TAG) == 0) {
ecl_frs_push(__the_env,ECL_PROTECT_TAG); \
if (__ecl_frs_push_result == 0) {
# define ECL_CATCH_ALL_IF_CAUGHT } else {
# define ECL_CATCH_ALL_END }} \
_except(_ecl_w32_exception_filter(GetExceptionInformation())) \
{ (void)0; } \
ecl_frs_pop(__the_env); } while(0)
#else
# define ECL_CATCH_ALL_BEGIN(the_env) do { \
const cl_env_ptr __the_env = (the_env); \
if (ecl_frs_push(__the_env,ECL_PROTECT_TAG) == 0) {
# define ECL_CATCH_ALL_BEGIN(the_env) do { \
const cl_env_ptr __the_env = (the_env); \
ecl_frs_push(__the_env,ECL_PROTECT_TAG); \
if (__ecl_frs_push_result == 0) {
# define ECL_CATCH_ALL_IF_CAUGHT } else {
# define ECL_CATCH_ALL_END } \
ecl_frs_pop(__the_env); } while(0)
@ -471,3 +563,5 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje
#ifdef __cplusplus
}
#endif
#endif /* ECL_STACKS_H */