From 42f0b2eaa560fc2043a0c9119d645e4f46e0bd23 Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@users.sourceforge.net>
Date: Thu, 27 Sep 2012 23:06:56 +0200
Subject: [PATCH] Fixed problems in ecl_register_current_thread(). First,
 allocation of environment and process structures could not proceed when
 ecl_process_env() did not return a valid environment. Second, we can only
 call GC_unregister_my_thread() when the thread was not created by the garbage
 collector itself, for which we must inspect the output of
 GC_register_my_thread()

---
 src/c/main.d            |  9 +++++----
 src/c/threads/process.d | 42 ++++++++++++++++++++++++++++++-----------
 src/h/external.h        |  4 ++++
 src/h/internal.h        |  2 +-
 4 files changed, 41 insertions(+), 16 deletions(-)

diff --git a/src/c/main.d b/src/c/main.d
index c61a78833..9ccb31688 100755
--- a/src/c/main.d
+++ b/src/c/main.d
@@ -134,6 +134,7 @@ ecl_init_env(cl_env_ptr env)
 	env->c_env = NULL;
 #if !defined(ECL_THREADS)
 	env->own_process = ECL_NIL;
+	env->cleanup = 0;
 #endif
 	env->string_pool = ECL_NIL;
 
@@ -207,7 +208,7 @@ _ecl_dealloc_env(cl_env_ptr env)
 }
 
 cl_env_ptr
-_ecl_alloc_env()
+_ecl_alloc_env(cl_env_ptr parent)
 {
 	/*
 	 * Allocates the lisp environment for a thread. Depending on which
@@ -242,10 +243,10 @@ _ecl_alloc_env()
                 size_t bytes = cl_core.default_sigmask_bytes;
                 if (bytes == 0) {
                         output->default_sigmask = 0;
-                } else if (ecl_option_values[ECL_OPT_BOOTED]) {
+                } else if (parent) {
                         output->default_sigmask = ecl_alloc_atomic(bytes);
                         memcpy(output->default_sigmask,
-                               ecl_process_env()->default_sigmask,
+                               parent->default_sigmask,
                                bytes);
                 } else {
                         output->default_sigmask = cl_core.default_sigmask;
@@ -518,7 +519,7 @@ cl_boot(int argc, char **argv)
 	init_unixint(0);
 	init_alloc();
 	GC_disable();
-	env = _ecl_alloc_env();
+	env = _ecl_alloc_env(0);
 #ifdef ECL_THREADS
         init_threads(env);
 #else
diff --git a/src/c/threads/process.d b/src/c/threads/process.d
index 36fe9270a..9ba21938f 100755
--- a/src/c/threads/process.d
+++ b/src/c/threads/process.d
@@ -333,9 +333,11 @@ alloc_process(cl_object name, cl_object initial_bindings)
 bool
 ecl_import_current_thread(cl_object name, cl_object bindings)
 {
+	struct cl_env_struct env_aux[1];
 	cl_object process;
 	pthread_t current;
 	cl_env_ptr env;
+	int registered;
 #ifdef ECL_WINDOWS_THREADS
 	{
 	HANDLE aux = GetCurrentThread();
@@ -352,7 +354,18 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
 	current = pthread_self();
 #endif
 #ifdef GBC_BOEHM
-	GC_register_my_thread((void*)&name);
+	switch (GC_register_my_thread((void*)&name)) {
+	case GC_SUCCESS:
+		registered = 1;
+		break;
+	case GC_DUPLICATE:
+		/* Thread was probably created using the GC hooks
+		 * for thread creation */
+		registered = 0;
+		break;
+	default:
+		return 0;
+	}
 #endif
 	{
 		cl_object processes = cl_core.processes;
@@ -363,17 +376,20 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
 				return 0;
 		}
 	}
-	process = alloc_process(name, bindings);
+	/* We need a fake env to allow for interrupts blocking. */
+	env_aux->disable_interrupts = 1;
+	ecl_set_process_env(env_aux);
+	env = _ecl_alloc_env(0);
+	ecl_set_process_env(env);
+	env->cleanup = registered;
+
+	/* Link environment and process together */
+	env->own_process = process = alloc_process(name, bindings);
+	process->process.env = env;
         process->process.phase = ECL_PROCESS_BOOTING;
 	process->process.thread = current;
 	ecl_list_process(process);
 
-	/* Link environment and process together */
-	env = _ecl_alloc_env();
-	env->own_process = process;
-	process->process.env = env;
-
-	ecl_set_process_env(env);
 	ecl_init_env(env);
 	env->bindings_array = process->process.initial_bindings;
         env->thread_local_bindings_size = env->bindings_array->vector.dim;
@@ -389,9 +405,13 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
 void
 ecl_release_current_thread(void)
 {
-	thread_cleanup(ecl_process_env()->own_process);
+	cl_env_ptr env = ecl_process_env();
+	int cleanup = env->cleanup;
+	thread_cleanup(env->own_process);
 #ifdef GBC_BOEHM
-	GC_unregister_my_thread();
+	if (cleanup) {
+		GC_unregister_my_thread();
+	}
 #endif
 }
 
@@ -491,7 +511,7 @@ mp_process_enable(cl_object process)
 	ecl_list_process(process);
 
 	/* Link environment and process together */
-	process_env = _ecl_alloc_env();
+	process_env = _ecl_alloc_env(ecl_process_env());
 	process_env->own_process = process;
 	process->process.env = process_env;
 
diff --git a/src/h/external.h b/src/h/external.h
index 847d109a1..38e6ebf3c 100755
--- a/src/h/external.h
+++ b/src/h/external.h
@@ -137,6 +137,10 @@ struct cl_env_struct {
 
 	/* Segmentation fault address */
 	void *fault_address;
+
+#ifdef ECL_THREADS
+	int cleanup;
+#endif
 };
 
 #ifndef __GNUC__
diff --git a/src/h/internal.h b/src/h/internal.h
index 00c454c77..b6d3b97e8 100755
--- a/src/h/internal.h
+++ b/src/h/internal.h
@@ -52,7 +52,7 @@ extern void init_threads(cl_env_ptr);
 extern void ecl_init_env(cl_env_ptr);
 extern void init_lib_LSP(cl_object);
 
-extern cl_env_ptr _ecl_alloc_env(void);
+extern cl_env_ptr _ecl_alloc_env(cl_env_ptr parent);
 extern void _ecl_dealloc_env(cl_env_ptr);
 
 /* alloc.d/alloc_2.d */