-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
\f
C level threads.
*/
+#include "libguile/_scm.h"
+
+#if HAVE_UNISTD_H
#include <unistd.h>
+#endif
#include <stdio.h>
#include <assert.h>
+#if HAVE_SYS_TIME_H
#include <sys/time.h>
+#endif
-#include "libguile/_scm.h"
#include "libguile/validate.h"
#include "libguile/root.h"
#include "libguile/eval.h"
enqueue (SCM q, SCM t)
{
SCM c = scm_cons (t, SCM_EOL);
- if (SCM_NULLP (SCM_CDR (q)))
+ if (scm_is_null (SCM_CDR (q)))
SCM_SETCDR (q, c);
else
SCM_SETCDR (SCM_CAR (q), c);
remqueue (SCM q, SCM c)
{
SCM p, prev = q;
- for (p = SCM_CDR (q); !SCM_NULLP (p); p = SCM_CDR (p))
+ for (p = SCM_CDR (q); !scm_is_null (p); p = SCM_CDR (p))
{
- if (SCM_EQ_P (p, c))
+ if (scm_is_eq (p, c))
{
- if (SCM_EQ_P (c, SCM_CAR (q)))
+ if (scm_is_eq (c, SCM_CAR (q)))
SCM_SETCAR (q, SCM_CDR (c));
SCM_SETCDR (prev, SCM_CDR (c));
return;
dequeue (SCM q)
{
SCM c = SCM_CDR (q);
- if (SCM_NULLP (c))
+ if (scm_is_null (c))
return SCM_BOOL_F;
else
{
SCM_SETCDR (q, SCM_CDR (c));
- if (SCM_NULLP (SCM_CDR (q)))
+ if (scm_is_null (SCM_CDR (q)))
SCM_SETCAR (q, SCM_EOL);
return SCM_CAR (c);
}
{
scm_thread *t = SCM_THREAD_DATA (exp);
scm_puts ("#<thread ", port);
- scm_intprint ((unsigned long)t->thread, 10, port);
+ scm_uintprint ((size_t)t->thread, 10, port);
scm_puts (" (", port);
- scm_intprint ((unsigned long)t, 16, port);
+ scm_uintprint ((scm_t_bits)t, 16, port);
scm_puts (")>", port);
return 1;
}
scm_thread *c = SCM_CURRENT_THREAD;
/* record top of stack for the GC */
- c->top = (SCM_STACKITEM *)&c;
+ c->top = SCM_STACK_PTR (&c);
/* save registers. */
SCM_FLUSH_REGISTER_WINDOWS;
setjmp (c->regs);
reached. Return 0 when it has been unblocked; errno otherwise.
*/
static int
-timed_block (const struct timespec *at)
+timed_block (const scm_t_timespec *at)
{
int err;
scm_thread *t = suspend ();
static void *
launch_thread (void *p)
{
- really_launch ((SCM_STACKITEM *)&p, (launch_data *)p);
+ really_launch (SCM_STACK_PTR (&p), (launch_data *) p);
return 0;
}
SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 2, 0, 0,
(SCM thunk, SCM handler),
-"Evaluate @var{(thunk)} in a new thread, and new dynamic context, "
+"Evaluate @code{(@var{thunk})} in a new thread, and new dynamic context, "
"returning a new thread object representing the thread. "
"If an error occurs during evaluation, call error-thunk, passing it an "
"error code describing the condition. "
"All the evaluation rules for dynamic roots apply to threads.")
#define FUNC_NAME s_scm_call_with_new_thread
{
- SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), thunk, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)), handler, SCM_ARG2,
+ SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), thunk, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (handler)), handler, SCM_ARG2,
FUNC_NAME);
return create_thread ((scm_t_catch_body) scm_call_0, thunk,
"Move the calling thread to the end of the scheduling queue.")
#define FUNC_NAME s_scm_yield
{
- return SCM_BOOL (scm_thread_yield);
+ return scm_from_bool (scm_thread_yield ());
}
#undef FUNC_NAME
SCM res;
SCM_VALIDATE_THREAD (1, thread);
- if (SCM_EQ_P (cur_thread, thread))
+ if (scm_is_eq (cur_thread, thread))
SCM_MISC_ERROR ("can not join the current thread", SCM_EOL);
t = SCM_THREAD_DATA (thread);
else
{
SCM next = dequeue (m->waiting);
- if (!SCM_FALSEP (next))
+ if (scm_is_true (next))
{
m->owner = next;
unblock (SCM_THREAD_DATA (next));
static int
fair_cond_timedwait (fair_cond *c,
fair_mutex *m,
- const struct timespec *waittime)
+ const scm_t_timespec *waittime)
{
int err;
scm_i_plugin_mutex_lock (&c->lock);
{
SCM th;
scm_i_plugin_mutex_lock (&c->lock);
- if (!SCM_FALSEP (th = dequeue (c->waiting)))
+ if (scm_is_true (th = dequeue (c->waiting)))
unblock (SCM_THREAD_DATA (th));
scm_i_plugin_mutex_unlock (&c->lock);
return 0;
{
SCM th;
scm_i_plugin_mutex_lock (&c->lock);
- while (!SCM_FALSEP (th = dequeue (c->waiting)))
+ while (scm_is_true (th = dequeue (c->waiting)))
unblock (SCM_THREAD_DATA (th));
scm_i_plugin_mutex_unlock (&c->lock);
return 0;
"is returned. ")
#define FUNC_NAME s_scm_timed_wait_condition_variable
{
- struct timespec waittime;
+ scm_t_timespec waittime;
int err;
SCM_VALIDATE_CONDVAR (1, cv);
if (!SCM_UNBNDP (t))
{
- if (SCM_CONSP (t))
+ if (scm_is_pair (t))
{
SCM_VALIDATE_UINT_COPY (3, SCM_CAR (t), waittime.tv_sec);
SCM_VALIDATE_UINT_COPY (3, SCM_CDR (t), waittime.tv_nsec);
scm_threads_mark_stacks (void)
{
volatile SCM c;
- for (c = all_threads; !SCM_NULLP (c); c = SCM_CDR (c))
+
+ for (c = all_threads; !scm_is_null (c); c = SCM_CDR (c))
{
scm_thread *t = SCM_THREAD_DATA (SCM_CAR (c));
if (!THREAD_INITIALIZED_P (t))
/* Not fully initialized yet. */
continue;
}
+
if (t->top == NULL)
{
- long stack_len;
-#ifdef SCM_DEBUG
- if (t->thread != scm_thread_self ())
- abort ();
-#endif
- /* Active thread */
- /* stack_len is long rather than sizet in order to guarantee
- that &stack_len is long aligned */
-#ifdef STACK_GROWS_UP
- stack_len = ((SCM_STACKITEM *) (&t) -
- (SCM_STACKITEM *) thread->base);
-
- /* Protect from the C stack. This must be the first marking
- * done because it provides information about what objects
- * are "in-use" by the C code. "in-use" objects are those
- * for which the information about length and base address must
- * remain usable. This requirement is stricter than a liveness
- * requirement -- in particular, it constrains the implementation
- * of scm_resizuve.
+ /* Thread has not been suspended, which should never happen.
*/
- SCM_FLUSH_REGISTER_WINDOWS;
- /* This assumes that all registers are saved into the jmp_buf */
- setjmp (scm_save_regs_gc_mark);
- scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
- ((size_t) sizeof scm_save_regs_gc_mark
- / sizeof (SCM_STACKITEM)));
-
- scm_mark_locations (((size_t) t->base,
- (sizet) stack_len));
-#else
- stack_len = ((SCM_STACKITEM *) t->base -
- (SCM_STACKITEM *) (&t));
-
- /* Protect from the C stack. This must be the first marking
- * done because it provides information about what objects
- * are "in-use" by the C code. "in-use" objects are those
- * for which the information about length and base address must
- * remain usable. This requirement is stricter than a liveness
- * requirement -- in particular, it constrains the implementation
- * of scm_resizuve.
- */
- SCM_FLUSH_REGISTER_WINDOWS;
- /* This assumes that all registers are saved into the jmp_buf */
- setjmp (scm_save_regs_gc_mark);
- scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
- ((size_t) sizeof scm_save_regs_gc_mark
- / sizeof (SCM_STACKITEM)));
-
- scm_mark_locations ((SCM_STACKITEM *) &t,
- stack_len);
-#endif
+ abort ();
}
- else
- {
- /* Suspended thread */
-#ifdef STACK_GROWS_UP
- long stack_len = t->top - t->base;
- scm_mark_locations (t->base, stack_len);
+
+ {
+#if SCM_STACK_GROWS_UP
+ scm_mark_locations (t->base, t->top - t->base);
#else
- long stack_len = t->base - t->top;
- scm_mark_locations (t->top, stack_len);
+ scm_mark_locations (t->top, t->base - t->top);
#endif
- scm_mark_locations ((SCM_STACKITEM *) t->regs,
- ((size_t) sizeof(t->regs)
- / sizeof (SCM_STACKITEM)));
- }
+ }
+ scm_mark_locations ((SCM_STACKITEM *) t->regs,
+ ((size_t) sizeof(t->regs)
+ / sizeof (SCM_STACKITEM)));
}
+
+ SCM_MARK_BACKING_STORE ();
}
/*** Select */
return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F);
}
+scm_t_thread
+scm_c_scm2thread (SCM thread)
+{
+ return SCM_THREAD_DATA (thread)->thread;
+}
+
int
scm_mutex_lock (scm_t_mutex *m)
{
}
int
-scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m, const struct timespec *wt)
+scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m, const scm_t_timespec *wt)
{
scm_thread *t = scm_i_leave_guile ();
int res = scm_i_plugin_cond_timedwait (c, m, wt);
return res;
}
+void *
+scm_getspecific (scm_t_key k)
+{
+ return scm_i_plugin_getspecific (k);
+}
+
+int
+scm_setspecific (scm_t_key k, void *s)
+{
+ return scm_i_plugin_setspecific (k, s);
+}
+
void
scm_enter_guile ()
{
"Return @code{#t} iff @var{thread} has exited.\n")
#define FUNC_NAME s_scm_thread_exited_p
{
- return SCM_BOOL (scm_c_thread_exited_p (thread));
+ return scm_from_bool (scm_c_thread_exited_p (thread));
}
#undef FUNC_NAME
static scm_t_cond wake_up_cond;
int scm_i_thread_go_to_sleep;
-static int gc_section_count = 0;
static int threads_initialized_p = 0;
void
scm_i_thread_put_to_sleep ()
{
- if (threads_initialized_p && !gc_section_count++)
+ if (threads_initialized_p)
{
SCM threads;
+
+ /* We leave Guile completely before locking the
+ thread_admin_mutex. This ensures that other threads can put
+ us to sleep while we block on that mutex.
+ */
+ scm_i_leave_guile ();
scm_i_plugin_mutex_lock (&thread_admin_mutex);
threads = all_threads;
/* Signal all threads to go to sleep */
scm_i_thread_go_to_sleep = 1;
- for (; !SCM_NULLP (threads); threads = SCM_CDR (threads))
- if (SCM_CAR (threads) != cur_thread)
- {
- scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
- scm_i_plugin_mutex_lock (&t->heap_mutex);
- }
+ for (; !scm_is_null (threads); threads = SCM_CDR (threads))
+ {
+ scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
+ scm_i_plugin_mutex_lock (&t->heap_mutex);
+ }
scm_i_thread_go_to_sleep = 0;
}
}
{
/* Don't need to lock thread_admin_mutex here since we are single threaded */
SCM threads = all_threads;
- for (; !SCM_NULLP (threads); threads = SCM_CDR (threads))
+ for (; !scm_is_null (threads); threads = SCM_CDR (threads))
if (SCM_CAR (threads) != cur_thread)
{
scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
void
scm_i_thread_wake_up ()
{
- if (threads_initialized_p && !--gc_section_count)
+ if (threads_initialized_p)
{
SCM threads;
threads = all_threads;
scm_i_plugin_cond_broadcast (&wake_up_cond);
- for (; !SCM_NULLP (threads); threads = SCM_CDR (threads))
- if (SCM_CAR (threads) != cur_thread)
- {
- scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
- scm_i_plugin_mutex_unlock (&t->heap_mutex);
- }
+ for (; !scm_is_null (threads); threads = SCM_CDR (threads))
+ {
+ scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
+ scm_i_plugin_mutex_unlock (&t->heap_mutex);
+ }
scm_i_plugin_mutex_unlock (&thread_admin_mutex);
+ scm_i_enter_guile (SCM_CURRENT_THREAD);
}
}
scm_t_mutex scm_i_critical_section_mutex;
scm_t_rec_mutex scm_i_defer_mutex;
-#ifdef USE_PTHREAD_THREADS
-#include "libguile/pthread-threads.c"
+#if SCM_USE_PTHREAD_THREADS
+# include "libguile/pthread-threads.c"
#endif
#include "libguile/threads-plugin.c"
scm_threads_prehistory ()
{
scm_thread *t;
-#ifdef USE_PTHREAD_THREADS
+#if SCM_USE_PTHREAD_THREADS
/* Must be called before any initialization of a mutex. */
scm_init_pthread_threads ();
#endif
threads_initialized_p = 1;
}
+/* scm_i_misc_mutex is intended for miscellaneous uses, to protect
+ operations which are non-reentrant or non-thread-safe but which are
+ either not important enough or not used often enough to deserve their own
+ private mutex. */
+SCM_GLOBAL_MUTEX (scm_i_misc_mutex);
+
void
scm_init_thread_procs ()
{
HCoop / bpt / guile.git / blobdiff