-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
+ * 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+ * Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include "libguile/bdw-gc.h"
#include "libguile/_scm.h"
+#include <stdlib.h>
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#include <sys/time.h>
#endif
+#if HAVE_PTHREAD_NP_H
+# include <pthread_np.h>
+#endif
+
#include <assert.h>
+#include <fcntl.h>
+#include <nproc.h>
#include "libguile/validate.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/weaks.h"
-#ifdef __MINGW32__
-#ifndef ETIMEDOUT
-# define ETIMEDOUT WSAETIMEDOUT
-#endif
-# include <fcntl.h>
-# include <process.h>
-# define pipe(fd) _pipe (fd, 256, O_BINARY)
-#endif /* __MINGW32__ */
-
#include <full-read.h>
};
static int
-GC_register_my_thread (struct GC_stack_base *)
+GC_register_my_thread (struct GC_stack_base *stack_base)
{
return GC_UNIMPLEMENTED;
}
return pthread_get_stackaddr_np (pthread_self ());
}
+#elif HAVE_PTHREAD_ATTR_GET_NP
+/* This one is for FreeBSD 9. */
+static void *
+get_thread_stack_base ()
+{
+ pthread_attr_t attr;
+ void *start, *end;
+ size_t size;
+
+ pthread_attr_init (&attr);
+ pthread_attr_get_np (pthread_self (), &attr);
+ pthread_attr_getstack (&attr, &start, &size);
+ pthread_attr_destroy (&attr);
+
+ end = (char *)start + size;
+
+#if SCM_STACK_GROWS_UP
+ return start;
+#else
+ return end;
+#endif
+}
+
#else
#error Threads enabled with old BDW-GC, but missing get_thread_stack_base impl. Please upgrade to libgc >= 7.1.
#endif
static int
-GC_get_stack_base (struct GC_stack_base *)
+GC_get_stack_base (struct GC_stack_base *stack_base)
{
stack_base->mem_base = get_thread_stack_base ();
#ifdef __ia64__
static SCM scm_i_default_dynamic_state;
+/* Run when a fluid is collected. */
+void
+scm_i_reset_fluid (size_t n)
+{
+ scm_i_thread *t;
+
+ scm_i_pthread_mutex_lock (&thread_admin_mutex);
+ for (t = all_threads; t; t = t->next_thread)
+ if (SCM_I_DYNAMIC_STATE_P (t->dynamic_state))
+ {
+ SCM v = SCM_I_DYNAMIC_STATE_FLUIDS (t->dynamic_state);
+
+ if (n < SCM_SIMPLE_VECTOR_LENGTH (v))
+ SCM_SIMPLE_VECTOR_SET (v, n, SCM_UNDEFINED);
+ }
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+}
+
/* Perform first stage of thread initialisation, in non-guile mode.
*/
static void
guilify_self_1 (struct GC_stack_base *base)
{
- scm_i_thread *t = scm_gc_malloc (sizeof (scm_i_thread), "thread");
-
- t->pthread = scm_i_pthread_self ();
- t->handle = SCM_BOOL_F;
- t->result = SCM_BOOL_F;
- t->cleanup_handler = SCM_BOOL_F;
- t->mutexes = SCM_EOL;
- t->held_mutex = NULL;
- t->join_queue = SCM_EOL;
- t->dynamic_state = SCM_BOOL_F;
- t->dynwinds = SCM_EOL;
- t->active_asyncs = SCM_EOL;
- t->block_asyncs = 1;
- t->pending_asyncs = 1;
- t->critical_section_level = 0;
- t->base = base->mem_base;
+ scm_i_thread t;
+
+ /* We must arrange for SCM_I_CURRENT_THREAD to point to a valid value
+ before allocating anything in this thread, because allocation could
+ cause GC to run, and GC could cause finalizers, which could invoke
+ Scheme functions, which need the current thread to be set. */
+
+ t.pthread = scm_i_pthread_self ();
+ t.handle = SCM_BOOL_F;
+ t.result = SCM_BOOL_F;
+ t.cleanup_handler = SCM_BOOL_F;
+ t.mutexes = SCM_EOL;
+ t.held_mutex = NULL;
+ t.join_queue = SCM_EOL;
+ t.dynamic_state = SCM_BOOL_F;
+ t.dynwinds = SCM_EOL;
+ t.active_asyncs = SCM_EOL;
+ t.block_asyncs = 1;
+ t.pending_asyncs = 1;
+ t.critical_section_level = 0;
+ t.base = base->mem_base;
#ifdef __ia64__
- t->register_backing_store_base = base->reg-base;
+ t.register_backing_store_base = base->reg-base;
#endif
- t->continuation_root = SCM_EOL;
- t->continuation_base = t->base;
- scm_i_pthread_cond_init (&t->sleep_cond, NULL);
- t->sleep_mutex = NULL;
- t->sleep_object = SCM_BOOL_F;
- t->sleep_fd = -1;
-
- if (pipe (t->sleep_pipe) != 0)
+ t.continuation_root = SCM_EOL;
+ t.continuation_base = t.base;
+ scm_i_pthread_cond_init (&t.sleep_cond, NULL);
+ t.sleep_mutex = NULL;
+ t.sleep_object = SCM_BOOL_F;
+ t.sleep_fd = -1;
+
+ if (pipe2 (t.sleep_pipe, O_CLOEXEC) != 0)
/* FIXME: Error conditions during the initialization phase are handled
gracelessly since public functions such as `scm_init_guile ()'
currently have type `void'. */
abort ();
- scm_i_pthread_mutex_init (&t->admin_mutex, NULL);
- t->current_mark_stack_ptr = NULL;
- t->current_mark_stack_limit = NULL;
- t->canceled = 0;
- t->exited = 0;
- t->guile_mode = 0;
+ scm_i_pthread_mutex_init (&t.admin_mutex, NULL);
+ t.current_mark_stack_ptr = NULL;
+ t.current_mark_stack_limit = NULL;
+ t.canceled = 0;
+ t.exited = 0;
+ t.guile_mode = 0;
- scm_i_pthread_setspecific (scm_i_thread_key, t);
+ /* The switcheroo. */
+ {
+ scm_i_thread *t_ptr = &t;
+
+ GC_disable ();
+ t_ptr = GC_malloc (sizeof (scm_i_thread));
+ memcpy (t_ptr, &t, sizeof t);
+
+ scm_i_pthread_setspecific (scm_i_thread_key, t_ptr);
#ifdef SCM_HAVE_THREAD_STORAGE_CLASS
- /* Cache the current thread in TLS for faster lookup. */
- scm_i_current_thread = t;
+ /* Cache the current thread in TLS for faster lookup. */
+ scm_i_current_thread = t_ptr;
#endif
- scm_i_pthread_mutex_lock (&thread_admin_mutex);
- t->next_thread = all_threads;
- all_threads = t;
- thread_count++;
- scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+ scm_i_pthread_mutex_lock (&thread_admin_mutex);
+ t_ptr->next_thread = all_threads;
+ all_threads = t_ptr;
+ thread_count++;
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+
+ GC_enable ();
+ }
}
/* Perform second stage of thread initialisation, in guile mode.
#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
+static SCM
+call_cleanup (void *data)
+{
+ SCM *proc_p = data;
+ return scm_call_0 (*proc_p);
+}
+
/* Perform thread tear-down, in guile mode.
*/
static void *
{
scm_i_thread *t = (scm_i_thread *) v;
+ /* Ensure the signal handling thread has been launched, because we might be
+ shutting it down. This needs to be done in Guile mode. */
+ scm_i_ensure_signal_delivery_thread ();
+
if (!scm_is_false (t->cleanup_handler))
{
SCM ptr = t->cleanup_handler;
t->cleanup_handler = SCM_BOOL_F;
t->result = scm_internal_catch (SCM_BOOL_T,
- (scm_t_catch_body) scm_call_0, ptr,
+ call_cleanup, &ptr,
scm_handle_by_message_noexit, NULL);
}
static void *
do_thread_exit_trampoline (struct GC_stack_base *sb, void *v)
{
- void *ret;
- int registered;
-
- registered = GC_register_my_thread (sb);
-
- ret = scm_with_guile (do_thread_exit, v);
-
- if (registered == GC_SUCCESS)
- GC_unregister_my_thread ();
+ /* Won't hurt if we are already registered. */
+#if SCM_USE_PTHREAD_THREADS
+ GC_register_my_thread (sb);
+#endif
- return ret;
+ return scm_with_guile (do_thread_exit, v);
}
static void
/* This handler is executed in non-guile mode. */
scm_i_thread *t = (scm_i_thread *) v, **tp;
+ /* If we were canceled, we were unable to clear `t->guile_mode', so do
+ it here. */
+ t->guile_mode = 0;
+
/* If this thread was cancelled while doing a cond wait, it will
still have a mutex locked, so we unlock it here. */
if (t->held_mutex)
case but it doesn't hurt to be consistent. */
scm_i_pthread_setspecific (scm_i_thread_key, t);
- /* Ensure the signal handling thread has been launched, because we might be
- shutting it down. */
- scm_i_ensure_signal_delivery_thread ();
-
- /* Unblocking the joining threads needs to happen in guile mode
- since the queue is a SCM data structure. Trampoline through
- GC_call_with_stack_base so that the GC works even if it already
- cleaned up for this thread. */
- GC_call_with_stack_base (do_thread_exit_trampoline, v);
+ /* Scheme-level thread finalizers and other cleanup needs to happen in
+ guile mode. */
+ GC_call_with_stack_base (do_thread_exit_trampoline, t);
/* Removing ourself from the list of all threads needs to happen in
non-guile mode since all SCM values on our stack become
scm_i_pthread_mutex_unlock (&thread_admin_mutex);
scm_i_pthread_setspecific (scm_i_thread_key, NULL);
+
+#if SCM_USE_PTHREAD_THREADS
+ GC_unregister_my_thread ();
+#endif
}
static scm_i_pthread_once_t init_thread_key_once = SCM_I_PTHREAD_ONCE_INIT;
*/
scm_i_init_guile (base);
+#if defined (HAVE_GC_ALLOW_REGISTER_THREADS) && SCM_USE_PTHREAD_THREADS
/* Allow other threads to come in later. */
GC_allow_register_threads ();
+#endif
scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
}
scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
/* Register this thread with libgc. */
+#if SCM_USE_PTHREAD_THREADS
GC_register_my_thread (base);
+#endif
guilify_self_1 (base);
guilify_self_2 (parent);
else
{
fprintf (stderr, "Failed to get stack base for current thread.\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
}
-SCM_UNUSED static void
-scm_leave_guile_cleanup (void *x)
-{
- on_thread_exit (SCM_I_CURRENT_THREAD);
-}
-
struct with_guile_args
{
GC_fn_type func;
SCM_ASSERT (SCM_UNBNDP (handler) || scm_is_true (scm_procedure_p (handler)),
handler, SCM_ARG2, FUNC_NAME);
+ GC_collect_a_little ();
data.parent = scm_current_dynamic_state ();
data.thunk = thunk;
data.handler = handler;
if (SCM_I_IS_THREAD (new_owner))
{
scm_i_thread *t = SCM_I_THREAD_DATA (new_owner);
+
+ /* FIXME: The order in which `t->admin_mutex' and
+ `m->lock' are taken differs from that in
+ `on_thread_exit', potentially leading to deadlocks. */
scm_i_pthread_mutex_lock (&t->admin_mutex);
/* Only keep a weak reference to MUTEX so that it's not
waittime = &cwaittime;
}
+ if (!SCM_UNBNDP (owner) && !scm_is_false (owner))
+ SCM_VALIDATE_THREAD (3, owner);
+
exception = fat_mutex_lock (m, waittime, owner, &ret);
if (!scm_is_false (exception))
scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1);
}
#undef FUNC_NAME
+static void
+lock_mutex_return_void (SCM mx)
+{
+ (void) scm_lock_mutex (mx);
+}
+
+static void
+unlock_mutex_return_void (SCM mx)
+{
+ (void) scm_unlock_mutex (mx);
+}
+
void
scm_dynwind_lock_mutex (SCM mutex)
{
- scm_dynwind_unwind_handler_with_scm ((void(*)(SCM))scm_unlock_mutex, mutex,
+ scm_dynwind_unwind_handler_with_scm (unlock_mutex_return_void, mutex,
SCM_F_WIND_EXPLICITLY);
- scm_dynwind_rewind_handler_with_scm ((void(*)(SCM))scm_lock_mutex, mutex,
+ scm_dynwind_rewind_handler_with_scm (lock_mutex_return_void, mutex,
SCM_F_WIND_EXPLICITLY);
}
}
#undef FUNC_NAME
+SCM_DEFINE (scm_total_processor_count, "total-processor-count", 0, 0, 0,
+ (void),
+ "Return the total number of processors of the machine, which\n"
+ "is guaranteed to be at least 1. A ``processor'' here is a\n"
+ "thread execution unit, which can be either:\n\n"
+ "@itemize\n"
+ "@item an execution core in a (possibly multi-core) chip, in a\n"
+ " (possibly multi- chip) module, in a single computer, or\n"
+ "@item a thread execution unit inside a core in the case of\n"
+ " @dfn{hyper-threaded} CPUs.\n"
+ "@end itemize\n\n"
+ "Which of the two definitions is used, is unspecified.\n")
+#define FUNC_NAME s_scm_total_processor_count
+{
+ return scm_from_ulong (num_processors (NPROC_ALL));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_current_processor_count, "current-processor-count", 0, 0, 0,
+ (void),
+ "Like @code{total-processor-count}, but return the number of\n"
+ "processors available to the current process. See\n"
+ "@code{setaffinity} and @code{getaffinity} for more\n"
+ "information.\n")
+#define FUNC_NAME s_scm_current_processor_count
+{
+ return scm_from_ulong (num_processors (NPROC_CURRENT));
+}
+#undef FUNC_NAME
+
+
+\f
+
static scm_i_pthread_cond_t wake_up_cond;
static int threads_initialized_p = 0;
return (void *) ctx->uc_mcontext.sc_ar_bsp;
}
# endif /* linux */
+# ifdef __FreeBSD__
+# include <ucontext.h>
+void *
+scm_ia64_register_backing_store_base (void)
+{
+ return (void *)0x8000000000000000;
+}
+void *
+scm_ia64_ar_bsp (const void *opaque)
+{
+ const ucontext_t *ctx = opaque;
+ return (void *)(ctx->uc_mcontext.mc_special.bspstore
+ + ctx->uc_mcontext.mc_special.ndirty);
+}
+# endif /* __FreeBSD__ */
#endif /* __ia64__ */
HCoop / bpt / guile.git / blobdiff