diff --git a/src/c/main.d b/src/c/main.d index 3194330df..d49528b72 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -579,7 +579,7 @@ cl_boot(int argc, char **argv) #endif #ifdef ECL_THREADS - env->bindings_array = si_make_vector(Ct, MAKE_FIXNUM(256), + env->bindings_array = si_make_vector(Ct, MAKE_FIXNUM(1024), Cnil, Cnil, Cnil, Cnil); si_fill_array_with_elt(env->bindings_array, OBJNULL, MAKE_FIXNUM(0), Cnil); env->thread_local_bindings_size = env->bindings_array->vector.dim; diff --git a/src/c/stacks.d b/src/c/stacks.d index c1edda3bf..a9eda6750 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -153,6 +153,8 @@ ecl_bds_overflow(void) if (env->bds_limit >= last) { ecl_unrecoverable_error(env, stack_overflow_msg); } + print_lock("BDS OVERFLOW %p %p %p", Cnil, + env->bds_org, env->bds_top, env->bds_limit); env->bds_limit += margin; cl_cerror(6, make_constant_base_string("Extend stack size"), @'ext::stack-overflow', @':size', MAKE_FIXNUM(size), diff --git a/src/c/threads/barrier.d b/src/c/threads/barrier.d index 97a73d3a2..a57549890 100644 --- a/src/c/threads/barrier.d +++ b/src/c/threads/barrier.d @@ -147,6 +147,7 @@ decrement_counter(cl_fixnum *counter) own_process->process.waiting_for = barrier; counter = decrement_counter(&barrier->barrier.arrivers_count); if (counter == 0) { + 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. */ @@ -155,10 +156,12 @@ decrement_counter(cl_fixnum *counter) ecl_enable_interrupts_env(the_env); output = @':unblocked'; } else if (counter > 0) { + print_lock("barrier %p waiting", barrier, barrier); ecl_enable_interrupts_env(the_env); ecl_wait_on(the_env, barrier_wait_condition, barrier); output = Ct; } else { + print_lock("barrier %p pass-through", barrier, barrier); /* Barrier disabled */ output = Cnil; } diff --git a/src/c/threads/mutex.d b/src/c/threads/mutex.d index f1f9db6fb..a8dcb2dc5 100644 --- a/src/c/threads/mutex.d +++ b/src/c/threads/mutex.d @@ -54,7 +54,7 @@ ecl_make_lock(cl_object name, bool recursive) return output; } -@(defun mp::make-lock (&key name ((:recursive recursive) Ct)) +@(defun mp::make-lock (&key name ((:recursive recursive) Cnil)) @ @(return ecl_make_lock(name, !Null(recursive))) @) @@ -112,13 +112,14 @@ mp_giveup_lock(cl_object lock) } if (--lock->lock.counter == 0) { lock->lock.owner = Cnil; + print_lock("releasing %p\t", lock, lock); ecl_wakeup_waiters(env, lock, ECL_WAKEUP_ONE); + } else { + print_lock("released %p\t", lock, lock); } ecl_return1(env, Ct); } -#define print_lock(a,b,...) (void)0 - static cl_object get_lock_inner(cl_env_ptr env, cl_object lock) { @@ -129,7 +130,7 @@ get_lock_inner(cl_env_ptr env, cl_object lock) (AO_t)Cnil, (AO_t)own_process)) { lock->lock.counter = 1; output = Ct; - print_lock("acquiring\t", lock, lock); + print_lock("acquired %p\t", lock, lock); } else if (lock->lock.owner == own_process) { unlikely_if (!lock->lock.recursive) { FEerror_not_a_recursive_lock(lock); @@ -137,6 +138,8 @@ get_lock_inner(cl_env_ptr env, cl_object lock) ++lock->lock.counter; output = Ct; } else { + print_lock("failed acquiring %p for %d\t", lock, lock, + lock->lock.owner); output = Cnil; } ecl_enable_interrupts_env(env); diff --git a/src/c/threads/process.d b/src/c/threads/process.d index 1fc9b1430..d13234b29 100644 --- a/src/c/threads/process.d +++ b/src/c/threads/process.d @@ -198,7 +198,6 @@ thread_cleanup(void *aux) cl_env_ptr env = process->process.env; /* The following flags will disable all interrupts. */ AO_store((AO_t*)&process->process.phase, ECL_PROCESS_EXITING); - process->process.active = 0; ecl_unlist_process(process); mp_barrier_unblock(3, process->process.exit_barrier, @':disable', Ct); ecl_set_process_env(process->process.env = NULL); @@ -219,9 +218,9 @@ thread_entry_point(void *arg) /* * Upon entering this routine * process.env = our environment for lisp - * process.active = 2 * process.phase = ECL_PROCESS_BOOTING * signals are disabled in the environment + * the communication interrupt is disabled (sigmasked) * * This process will not receive signals that originate from * other processes. Furthermore, we expect not to get any @@ -233,6 +232,8 @@ thread_entry_point(void *arg) pthread_cleanup_push(thread_cleanup, (void *)process); #endif ecl_cs_set_org(env); + print_lock("ENVIRON %p %p %p %p", Cnil, process, + env->bds_org, env->bds_top, env->bds_limit); ecl_list_process(process); /* 2) Execute the code. The CATCH_ALL point is the destination @@ -240,7 +241,14 @@ thread_entry_point(void *arg) * do an unwind up to frs_top. */ CL_CATCH_ALL_BEGIN(env) { - process->process.active = 1; +#ifdef HAVE_SIGPROCMASK + { + sigset_t new; + sigemptyset(&new); + sigaddset(&new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); + pthread_sigmask(SIG_UNBLOCK, &new, NULL); + } +#endif process->process.phase = ECL_PROCESS_ACTIVE; ecl_enable_interrupts_env(env); si_trap_fpe(@'last', Ct); @@ -279,7 +287,6 @@ alloc_process(cl_object name, cl_object initial_bindings) { cl_object process = ecl_alloc_object(t_process), array; process->process.phase = ECL_PROCESS_INACTIVE; - process->process.active = 0; process->process.name = name; process->process.function = Cnil; process->process.args = Cnil; @@ -340,7 +347,6 @@ ecl_import_current_thread(cl_object name, cl_object bindings) ecl_set_process_env(env); process = alloc_process(name, bindings); process->process.phase = ECL_PROCESS_BOOTING; - process->process.active = 2; process->process.thread = current; process->process.env = env; env->own_process = process; @@ -350,7 +356,6 @@ ecl_import_current_thread(cl_object name, cl_object bindings) env->thread_local_bindings_size = env->bindings_array->vector.dim; env->thread_local_bindings = env->bindings_array->vector.self.t; ecl_enable_interrupts_env(env); - process->process.active = 1; process->process.phase = ECL_PROCESS_ACTIVE; return 1; } @@ -387,7 +392,7 @@ mp_process_preset(cl_narg narg, cl_object process, cl_object function, ...) cl_object mp_interrupt_process(cl_object process, cl_object function) { - if (mp_process_active_p(process) == Cnil) + unlikely_if (mp_process_active_p(process) == Cnil) FEerror("Cannot interrupt the inactive process ~A", 1, process); ecl_interrupt_process(process, function); @(return Ct) @@ -428,11 +433,7 @@ mp_process_resume(cl_object process) cl_object mp_process_kill(cl_object process) { - assert_type_process(process); - if (process->process.active && - process->process.phase != ECL_PROCESS_EXITING) { - return mp_interrupt_process(process, @'mp::exit-process'); - } + return mp_interrupt_process(process, @'mp::exit-process'); } cl_object @@ -445,15 +446,12 @@ mp_process_yield(void) cl_object mp_process_enable(cl_object process) { - /* - * We try to grab the process exit lock. If we achieve it that - * means the 1) process is not running or in the finalization - * or 2) it is in the initialization phase. The second case we - * can distinguish because process.active != 0. The first one - * is ok. - */ 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)) { @@ -473,7 +471,6 @@ mp_process_enable(cl_object process) process->process.parent = mp_current_process(); process->process.trap_fpe_bits = process->process.parent->process.env->trap_fpe_bits; - process->process.active = 2; /* Activate the barrier so that processes can immediately start waiting. */ mp_barrier_unblock(1, process->process.exit_barrier); @@ -500,8 +497,9 @@ mp_process_enable(cl_object process) */ #ifdef HAVE_SIGPROCMASK { - sigset_t previous; - pthread_sigmask(SIG_SETMASK, process_env->default_sigmask, &previous); + sigset_t previous, new = process_env->default_sigmask; + sigaddset(&new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); + pthread_sigmask(SIG_SETMASK, new, &previous); code = pthread_create(&process->process.thread, &pthreadattr, thread_entry_point, process); pthread_sigmask(SIG_SETMASK, &previous, NULL); @@ -518,7 +516,6 @@ mp_process_enable(cl_object process) mp_barrier_unblock(3, process->process.exit_barrier, @':disable', Ct); process->process.phase = ECL_PROCESS_INACTIVE; - process->process.active = 0; process->process.env = NULL; _ecl_dealloc_env(process_env); } @@ -555,7 +552,7 @@ cl_object mp_process_active_p(cl_object process) { assert_type_process(process); - @(return (process->process.active? Ct : Cnil)) + @(return (process->process.phase? Ct : Cnil)) } cl_object @@ -709,7 +706,6 @@ init_threads(cl_env_ptr env) main_thread = pthread_self(); #endif process = ecl_alloc_object(t_process); - process->process.active = 1; process->process.phase = ECL_PROCESS_ACTIVE; process->process.name = @'si::top-level'; process->process.function = Cnil; diff --git a/src/c/threads/queue.d b/src/c/threads/queue.d index 60162b705..dffbb0f8c 100644 --- a/src/c/threads/queue.d +++ b/src/c/threads/queue.d @@ -21,9 +21,6 @@ #include #include -#define print_lock(a,b,...) (void)0 - - void ECL_INLINE ecl_process_yield() { @@ -76,7 +73,7 @@ wait_queue_pop_all(cl_env_ptr the_env, cl_object q) } static ECL_INLINE cl_object -wait_queue_pop_one(cl_env_ptr the_env, cl_object q) +wait_queue_first_one(cl_env_ptr the_env, cl_object q) { cl_object output; ecl_disable_interrupts_env(the_env); @@ -84,8 +81,7 @@ wait_queue_pop_one(cl_env_ptr the_env, cl_object q) { output = q->queue.list; if (output != Cnil) - q->queue.list = ECL_CONS_CDR(output); - output = ECL_CONS_CAR(output); + output = ECL_CONS_CAR(output); } ecl_giveup_spinlock(&q->queue.spinlock); ecl_enable_interrupts_env(the_env); @@ -240,6 +236,7 @@ ecl_wait_on(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_ob if (ECL_CONS_CAR(o->queue.list) != own_process || condition(the_env, o) == Cnil) { + print_lock("suspending %p", o, o); do { /* This will wait until we get a signal that * demands some code being executed. Note that @@ -285,7 +282,7 @@ wakeup_this(cl_object p, int flags) { if (flags & ECL_WAKEUP_RESET_FLAG) p->process.waiting_for = Cnil; - print_lock("awaking\t\t%d", Cnil, fix(p->process.name)); + print_lock("awaking %p", p, p); if (flags & ECL_WAKEUP_KILL) mp_process_kill(p); else @@ -299,7 +296,7 @@ wakeup_all(cl_env_ptr the_env, cl_object q, int flags) while (!Null(queue)) { cl_object process = ECL_CONS_CAR(queue); queue = ECL_CONS_CDR(queue); - if (process->process.active) + if (process->process.phase != ECL_PROCESS_INACTIVE) wakeup_this(process, flags); } } @@ -308,10 +305,13 @@ static void wakeup_one(cl_env_ptr the_env, cl_object q, int flags) { do { - cl_object next = wait_queue_pop_one(the_env, q); - if (Null(next)) + cl_object next = wait_queue_first_one(the_env, q); + if (Null(next)) { + print_lock("no process to awake", q); return; - if (next->process.active) { + } + print_lock("awaking %p", q, next); + if (next->process.phase != ECL_PROCESS_INACTIVE) { wakeup_this(next, flags); return; } @@ -321,7 +321,6 @@ wakeup_one(cl_env_ptr the_env, cl_object q, int flags) void ecl_wakeup_waiters(cl_env_ptr the_env, cl_object q, int flags) { - print_lock("releasing\t", o); if (q->queue.list != Cnil) { if (flags & ECL_WAKEUP_ALL) { wakeup_all(the_env, q, flags); @@ -340,7 +339,8 @@ print_lock(char *prefix, cl_object l, ...) static cl_object lock = Cnil; va_list args; va_start(args, lock); - if (l == Cnil || l->lock.name == MAKE_FIXNUM(0)) { + return; + if (l == Cnil || FIXNUMP(l->lock.name)) { cl_env_ptr env = ecl_process_env(); ecl_get_spinlock(env, &lock); printf("\n%d\t", fix(env->own_process->process.name)); @@ -348,7 +348,7 @@ print_lock(char *prefix, cl_object l, ...) if (l != Cnil) { cl_object p = l->lock.queue_list; while (p != Cnil) { - printf(" %d", fix(ECL_CONS_CAR(p)->process.name)); + printf(" %x", fix(ECL_CONS_CAR(p)->process.name)); p = ECL_CONS_CDR(p); } } diff --git a/src/c/unixint.d b/src/c/unixint.d index 36b79d83e..12a8610e4 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -245,9 +245,7 @@ zombie_process(cl_env_ptr the_env) } else { /* When we are exiting a thread, we simply ignore all signals. */ cl_object process = the_env->own_process; - return (!process->process.active || - process->process.phase == ECL_PROCESS_EXITING); - return 0; + return (process->process.phase == ECL_PROCESS_INACTIVE); } #else return !the_env; diff --git a/src/h/internal.h b/src/h/internal.h index d62c93f83..e0f9b0ae7 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -469,6 +469,7 @@ extern cl_fixnum ecl_runtime(void); #ifdef ECL_THREADS extern void ecl_process_yield(void); extern void print_lock(char *s, cl_object lock, ...); +#define print_lock(a,b,...) ((void)0) extern void ecl_get_spinlock(cl_env_ptr env, cl_object *lock); extern void ecl_giveup_spinlock(cl_object *lock); diff --git a/src/h/object.h b/src/h/object.h index 7078fc7c7..fb4283dcd 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -881,7 +881,7 @@ enum { ECL_PROCESS_EXITING }; struct ecl_process { - HEADER1(active); + HEADER; cl_object name; cl_object function; cl_object args;