Removed the process.active field and instead used 'process.phase'. Added some debug statements. Threads are launched also with POSIX signals disabled (at least ECL's signal).

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;

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),

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;
 	}

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);

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;

src/c/threads/queue.d

@@ -21,9 +21,6 @@
 #include <ecl/ecl.h>
 #include <ecl/internal.h>
 
-#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);
 			}
 		}

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;

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);
 

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;