-/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2002 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 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.
- *
- * 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. */
-
-
-\f
-
-/* This file does some pretty hairy #inclusion. It probably seemed
- like a good idea at the time, but it doesn't now. Here's the
- structure, edited for relevance (!), last I checked:
-
- threads.c:
- threads.h
- coop-defs.h
- iselect.h
- coop-threads.c
- coop-threads.h
- coop-defs.h*
- ../qt/qt.h
- coop.c
- <qt.h>
-
- * second #inclusion
-*/
-
-#include <errno.h>
-
-#include "libguile/_scm.h"
-#include "libguile/dynwind.h"
-#include "libguile/smob.h"
-
-#include "libguile/threads.h"
-
-\f
-
-scm_t_bits scm_tc16_thread;
-scm_t_bits scm_tc16_mutex;
-scm_t_bits scm_tc16_condvar;
-
-\f
-/* Scheme-visible thread functions. */
-
-#ifdef USE_COOP_THREADS
-SCM_REGISTER_PROC(s_single_thread_p, "single-active-thread?", 0, 0, 0, scm_single_thread_p);
-#endif
-
-/* GJB:FIXME:DOC: SCM_REGISTER_PROC needs to permit a docstring,
- or these need to move into the file where the proc is defined. */
-
-SCM_REGISTER_PROC(s_yield, "yield", 0, 0, 0, scm_yield);
-/* If one or more threads are waiting to execute, calling yield forces an
-immediate context switch to one of them. Otherwise, yield has no effect.
-*/
-
-SCM_REGISTER_PROC(s_call_with_new_thread, "call-with-new-thread", 0, 0, 1, scm_call_with_new_thread);
-/* Evaluate @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. [Error codes are currently
-meaningless integers. In the future, real values will be specified.]
-If this happens, the error-thunk is called outside the scope of the new
-root -- it is called in the same dynamic context in which
-with-new-thread was evaluated, but not in the callers thread.
-
-All the evaluation rules for dynamic roots apply to threads.
-*/
-
-SCM_REGISTER_PROC(s_current_thread, "current-thread", 0, 0, 0, scm_current_thread);
-SCM_REGISTER_PROC(s_all_thread, "all-threads", 0, 0, 0, scm_all_threads);
-
-SCM_REGISTER_PROC(s_join_thread, "join-thread", 1, 0, 0, scm_join_thread);
-/* Suspend execution of the calling thread until the target @var{thread}
-terminates, unless the target @var{thread} has already terminated.
-*/
-
-SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0,
- (SCM thread),
- "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));
-}
-#undef FUNC_NAME
-
-SCM_REGISTER_PROC(s_make_mutex, "make-mutex", 0, 0, 0, scm_make_mutex);
-/* Create a new mutex object. */
-
-SCM_REGISTER_PROC(s_lock_mutex, "lock-mutex", 1, 0, 0, scm_lock_mutex);
-/* Lock @var{mutex}. If the mutex is already locked, the calling thread
-blocks until the mutex becomes available. The function returns when
-the calling thread owns the lock on @var{mutex}. */
-
-SCM_REGISTER_PROC(s_try_mutex, "try-mutex", 1, 0, 0, scm_try_mutex);
-/* Try to lock @var{mutex}. If the mutex is already locked by someone
-else, return @code{#f}. Else lock the mutex and return @code{#t}. */
-
-SCM_REGISTER_PROC(s_unlock_mutex, "unlock-mutex", 1, 0, 0, scm_unlock_mutex);
-/* Unlocks @var{mutex} if the calling thread owns the lock on @var{mutex}.
-Calling unlock-mutex on a mutex not owned by the current thread results
-in undefined behaviour. Once a mutex has been unlocked, one thread
-blocked on @var{mutex} is awakened and grabs the mutex lock. */
-
-SCM_REGISTER_PROC(s_make_condition_variable, "make-condition-variable", 0, 0, 0, scm_make_condition_variable);
-
-SCM_REGISTER_PROC(s_wait_condition_variable, "wait-condition-variable", 2, 1, 0, scm_timed_wait_condition_variable);
-
-SCM_REGISTER_PROC(s_signal_condition_variable, "signal-condition-variable", 1, 0, 0, scm_signal_condition_variable);
-
-SCM_REGISTER_PROC(s_broadcast_condition_variable, "broadcast-condition-variable", 1, 0, 0, scm_broadcast_condition_variable);
-
-SCM
-scm_wait_condition_variable (SCM c, SCM m)
-{
- return scm_timed_wait_condition_variable (c, m, SCM_UNDEFINED);
-}
-
-\f
-
-#ifdef USE_COOP_THREADS
-#include "libguile/coop-threads.c"
-#else
-#ifdef USE_COPT_THREADS
-#include "libguile/coop-pthreads.c"
-#else
-#include "libguile/null-threads.c"
-#endif
-#endif
-
-\f
-
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-int
-scm_mutex_init (scm_t_mutex *m)
-{
- scm_gc_protect_object (m->m = scm_make_mutex ());
- return 0;
-}
-
-int
-scm_mutex_lock (scm_t_mutex *m)
-{
- scm_lock_mutex (m->m);
- return 0;
-}
-
-int
-scm_mutex_trylock (scm_t_mutex *m)
-{
- return SCM_FALSEP (scm_try_mutex (m->m))? EBUSY : 0;
-}
-
-int
-scm_mutex_unlock (scm_t_mutex *m)
-{
- scm_unlock_mutex (m->m);
- return 0;
-}
-
-int
-scm_mutex_destroy (scm_t_mutex *m)
-{
- scm_gc_unprotect_object (m->m);
- return 0;
-}
-
-SCM_API int
-scm_cond_init (scm_t_cond *c, int *cattr)
-{
- scm_gc_protect_object (c->c = scm_make_condition_variable ());
- return 0;
-}
-
-int
-scm_cond_wait (scm_t_cond *c, scm_t_mutex *m)
-{
- scm_wait_condition_variable (c->c, m->m);
- return 0;
-}
-
-int
-scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m,
- const struct timespec *t)
-{
- return !SCM_FALSEP (scm_timed_wait_condition_variable (
- c->c, m->m, scm_cons (scm_long2num (t->tv_sec),
- scm_long2num (t->tv_nsec/1000))));
-}
-
-int
-scm_cond_signal (scm_t_cond *c)
-{
- scm_signal_condition_variable (c->c);
- return 0;
-}
-
-int
-scm_cond_broadcast (scm_t_cond *c)
-{
- scm_broadcast_condition_variable (c->c);
- return 0;
-}
-
-int
-scm_cond_destroy (scm_t_cond *c)
-{
- scm_gc_unprotect_object (c->c);
- return 0;
-}
-
-#endif
-
-\f
-
-void
-scm_init_threads (SCM_STACKITEM *i)
-{
- /* Initialize implementation specific details of the threads support */
- scm_threads_init (i);
-}
-
-void
-scm_init_thread_procs ()
-{
-#include "libguile/threads.x"
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002 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 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.
+ *
+ * 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. */
+
+
+\f
+
+/* This file implements nice Scheme level threads on top of the gastly
+ C level threads.
+*/
+
+#include <unistd.h>
+#include <stdio.h>
+#include <assert.h>
+#include <sys/time.h>
+
+#include "libguile/_scm.h"
+#include "libguile/validate.h"
+#include "libguile/root.h"
+#include "libguile/eval.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/threads.h"
+#include "libguile/dynwind.h"
+#include "libguile/iselect.h"
+
+/*** Queues */
+
+static SCM
+make_queue ()
+{
+ return scm_cons (SCM_EOL, SCM_EOL);
+}
+
+static SCM
+enqueue (SCM q, SCM t)
+{
+ SCM c = scm_cons (t, SCM_EOL);
+ if (SCM_NULLP (SCM_CDR (q)))
+ SCM_SETCDR (q, c);
+ else
+ SCM_SETCDR (SCM_CAR (q), c);
+ SCM_SETCAR (q, c);
+ return c;
+}
+
+static void
+remqueue (SCM q, SCM c)
+{
+ SCM p, prev = q;
+ for (p = SCM_CDR (q); !SCM_NULLP (p); p = SCM_CDR (p))
+ {
+ if (SCM_EQ_P (p, c))
+ {
+ if (SCM_EQ_P (c, SCM_CAR (q)))
+ SCM_SETCAR (q, SCM_CDR (c));
+ SCM_SETCDR (prev, SCM_CDR (c));
+ return;
+ }
+ prev = p;
+ }
+ abort ();
+}
+
+static SCM
+dequeue (SCM q)
+{
+ SCM c = SCM_CDR (q);
+ if (SCM_NULLP (c))
+ return SCM_BOOL_F;
+ else
+ {
+ SCM_SETCDR (q, SCM_CDR (c));
+ if (SCM_NULLP (SCM_CDR (q)))
+ SCM_SETCAR (q, SCM_EOL);
+ return SCM_CAR (c);
+ }
+}
+
+
+/*** Threads */
+
+typedef struct scm_thread {
+
+ /* Blocking.
+ */
+ scm_t_cond sleep_cond;
+ struct scm_thread *next_waiting;
+
+ scm_root_state *root;
+ SCM handle;
+ scm_t_thread thread;
+ SCM result;
+ int exited;
+
+ SCM joining_threads;
+
+ /* For keeping track of the stack and registers. */
+ SCM_STACKITEM *base;
+ SCM_STACKITEM *top;
+ jmp_buf regs;
+
+} scm_thread;
+
+static SCM
+make_thread (SCM creation_protects)
+{
+ SCM z;
+ scm_thread *t;
+ z = scm_make_smob (scm_tc16_thread);
+ t = SCM_THREAD_DATA (z);
+ t->handle = z;
+ t->result = creation_protects;
+ t->base = NULL;
+ t->joining_threads = make_queue ();
+ scm_cond_init (&t->sleep_cond);
+ t->exited = 0;
+ return z;
+}
+
+static void
+init_thread_creator (SCM thread, scm_t_thread th, scm_root_state *r)
+{
+ scm_thread *t = SCM_THREAD_DATA(thread);
+ t->root = r;
+ t->thread = th;
+#ifdef DEBUG
+ // fprintf (stderr, "%ld created %ld\n", pthread_self (), th);
+#endif
+}
+
+static void
+init_thread_creatant (SCM thread, SCM_STACKITEM *base)
+{
+ scm_thread *t = SCM_THREAD_DATA(thread);
+ t->base = base;
+ t->top = NULL;
+}
+
+static SCM
+thread_mark (SCM obj)
+{
+ scm_thread *t = SCM_THREAD_DATA (obj);
+ scm_gc_mark (t->result);
+ scm_gc_mark (t->joining_threads);
+ return t->root->handle;
+}
+
+static int
+thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_thread *t = SCM_THREAD_DATA (exp);
+ scm_puts ("#<thread ", port);
+ scm_intprint ((unsigned long)t, 16, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+static size_t
+thread_free (SCM obj)
+{
+ scm_thread *t = SCM_THREAD_DATA (obj);
+ if (!t->exited)
+ abort ();
+ scm_gc_free (t, sizeof (*t), "thread");
+ return 0;
+}
+
+/*** Fair mutexes */
+
+/* C level mutexes (such as POSIX mutexes) are not necessarily fair
+ but since we'd like to use a mutex for scheduling, we build a fair
+ one on top of the C one.
+*/
+
+typedef struct fair_mutex {
+ scm_t_mutex lock;
+ scm_thread *owner;
+ scm_thread *next_waiting, *last_waiting;
+} fair_mutex;
+
+static void
+fair_mutex_init (fair_mutex *m)
+{
+ scm_mutex_init (&m->lock);
+ m->owner = NULL;
+ m->next_waiting = NULL;
+ m->last_waiting = NULL;
+}
+
+static void
+fair_mutex_lock_1 (fair_mutex *m, scm_thread *t)
+{
+ if (m->owner == NULL)
+ m->owner = t;
+ else
+ {
+ t->next_waiting = NULL;
+ if (m->last_waiting)
+ m->last_waiting->next_waiting = t;
+ else
+ m->next_waiting = t;
+ m->last_waiting = t;
+ do
+ {
+ int err;
+ err = scm_cond_wait (&t->sleep_cond, &m->lock);
+ assert (err == 0);
+ }
+ while (m->owner != t);
+ assert (m->next_waiting == t);
+ m->next_waiting = t->next_waiting;
+ if (m->next_waiting == NULL)
+ m->last_waiting = NULL;
+ }
+ scm_mutex_unlock (&m->lock);
+}
+
+static void
+fair_mutex_lock (fair_mutex *m, scm_thread *t)
+{
+ scm_mutex_lock (&m->lock);
+ fair_mutex_lock_1 (m, t);
+}
+
+static void
+fair_mutex_unlock_1 (fair_mutex *m)
+{
+ scm_thread *t;
+ scm_mutex_lock (&m->lock);
+ // fprintf (stderr, "%ld unlocking\n", m->owner->pthread);
+ if ((t = m->next_waiting) != NULL)
+ {
+ m->owner = t;
+ scm_cond_signal (&t->sleep_cond);
+ }
+ else
+ m->owner = NULL;
+ // fprintf (stderr, "%ld unlocked\n", pthread_self ());
+}
+
+static void
+fair_mutex_unlock (fair_mutex *m)
+{
+ fair_mutex_unlock_1 (m);
+ scm_mutex_unlock (&m->lock);
+}
+
+/* Temporarily give up the mutex. This function makes sure that we
+ are on the wait queue before starting the next thread. Otherwise
+ the next thread might preempt us and we will have a hard time
+ getting on the wait queue.
+*/
+static void
+fair_mutex_yield (fair_mutex *m)
+{
+ scm_thread *self = m->owner;
+ fair_mutex_unlock_1 (m);
+ fair_mutex_lock_1 (m, self);
+}
+
+static int
+fair_cond_wait (scm_t_cond *c, fair_mutex *m)
+{
+ scm_thread *t = m->owner;
+ int err;
+ fair_mutex_unlock_1 (m);
+ err = scm_cond_wait (c, &m->lock);
+ fair_mutex_lock_1 (m, t);
+ return err;
+}
+
+static int
+fair_cond_timedwait (scm_t_cond *c, fair_mutex *m, struct timespec *at)
+{
+ int err;
+ scm_thread *t = m->owner;
+ fair_mutex_unlock_1 (m);
+ err = scm_cond_timedwait (c, &m->lock, at); /* XXX - signals? */
+ fair_mutex_lock_1 (m, t);
+ return err;
+}
+
+/*** Scheduling */
+
+/* When a thread wants to execute Guile functions, it locks the
+ guile_mutex.
+*/
+
+static fair_mutex guile_mutex;
+
+static SCM cur_thread;
+void *scm_i_thread_data;
+
+void
+scm_i_set_thread_data (void *data)
+{
+ scm_thread *t = SCM_THREAD_DATA (cur_thread);
+ scm_i_thread_data = data;
+ t->root = (scm_root_state *)data;
+}
+
+static void
+resume (scm_thread *t)
+{
+ cur_thread = t->handle;
+ scm_i_thread_data = t->root;
+ t->top = NULL;
+}
+
+static void
+enter_guile (scm_thread *t)
+{
+ fair_mutex_lock (&guile_mutex, t);
+ resume (t);
+}
+
+static scm_thread *
+suspend ()
+{
+ SCM cur = cur_thread;
+ scm_thread *c = SCM_THREAD_DATA (cur);
+
+ /* record top of stack for the GC */
+ c->top = (SCM_STACKITEM *)&c;
+ /* save registers. */
+ SCM_FLUSH_REGISTER_WINDOWS;
+ setjmp (c->regs);
+
+ return c;
+}
+
+static scm_thread *
+leave_guile ()
+{
+ scm_thread *c = suspend ();
+ fair_mutex_unlock (&guile_mutex);
+ return c;
+}
+
+int scm_i_switch_counter;
+
+SCM
+scm_yield ()
+{
+ /* Testing guile_mutex.next_waiting without locking guile_mutex.lock
+ is OK since the outcome is not critical. Even when it changes
+ after the test, we do the right thing.
+ */
+ if (guile_mutex.next_waiting)
+ {
+ scm_thread *t = suspend ();
+ fair_mutex_yield (&guile_mutex);
+ resume (t);
+ }
+ return SCM_BOOL_T;
+}
+
+/* Put the current thread to sleep until it is explicitely unblocked.
+ */
+static int
+block ()
+{
+ int err;
+ scm_thread *t = suspend ();
+ err = fair_cond_wait (&t->sleep_cond, &guile_mutex);
+ resume (t);
+ return err;
+}
+
+/* Put the current thread to sleep until it is explicitely unblocked
+ or until a signal arrives or until time AT (absolute time) is
+ reached. Return 0 when it has been unblocked; errno otherwise.
+ */
+static int
+timed_block (struct timespec *at)
+{
+ int err;
+ scm_thread *t = suspend ();
+ err = fair_cond_timedwait (&t->sleep_cond, &guile_mutex, at);
+ resume (t);
+ return err;
+}
+
+/* Unblock a sleeping thread.
+ */
+static void
+unblock (scm_thread *t)
+{
+ scm_cond_signal (&t->sleep_cond);
+}
+
+/*** Thread creation */
+
+static SCM all_threads;
+static int thread_count;
+
+typedef struct launch_data {
+ SCM thread;
+ SCM rootcont;
+ scm_t_catch_body body;
+ void *body_data;
+ scm_t_catch_handler handler;
+ void *handler_data;
+} launch_data;
+
+static SCM
+body_bootstrip (launch_data* data)
+{
+ /* First save the new root continuation */
+ data->rootcont = scm_root->rootcont;
+ return (data->body) (data->body_data);
+}
+
+static SCM
+handler_bootstrip (launch_data* data, SCM tag, SCM throw_args)
+{
+ scm_root->rootcont = data->rootcont;
+ return (data->handler) (data->handler_data, tag, throw_args);
+}
+
+static void
+really_launch (SCM_STACKITEM *base, launch_data *data)
+{
+ SCM thread = data->thread;
+ scm_thread *t = SCM_THREAD_DATA (thread);
+ init_thread_creatant (thread, base);
+ enter_guile (t);
+
+ data->rootcont = SCM_BOOL_F;
+ t->result =
+ scm_internal_cwdr ((scm_t_catch_body) body_bootstrip,
+ data,
+ (scm_t_catch_handler) handler_bootstrip,
+ data, base);
+ free (data);
+
+ scm_thread_detach (t->thread);
+ all_threads = scm_delq (thread, all_threads);
+ t->exited = 1;
+ thread_count--;
+ leave_guile ();
+}
+
+static void
+launch_thread (void *p)
+{
+ really_launch ((SCM_STACKITEM *)&p, (launch_data *)p);
+}
+
+static SCM
+create_thread (scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data,
+ SCM protects)
+{
+ SCM thread;
+
+ /* Make new thread. The first thing the new thread will do is to
+ lock guile_mutex. Thus, we can safely complete its
+ initialization after creating it. While the new thread starts,
+ all its data is protected via all_threads.
+ */
+
+ {
+ scm_t_thread th;
+ SCM root, old_winds;
+ launch_data *data;
+ int err;
+
+ /* Unwind wind chain. */
+ old_winds = scm_dynwinds;
+ scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
+
+ /* Allocate thread locals. */
+ root = scm_make_root (scm_root->handle);
+ data = scm_malloc (sizeof (launch_data));
+
+ /* Make thread. */
+ thread = make_thread (protects);
+ data->thread = thread;
+ data->body = body;
+ data->body_data = body_data;
+ data->handler = handler;
+ data->handler_data = handler_data;
+ err = scm_thread_create (&th, launch_thread, (void *) data);
+ if (err == 0)
+ {
+ init_thread_creator (thread, th, SCM_ROOT_STATE (root));
+ all_threads = scm_cons (thread, all_threads);
+ thread_count++;
+ }
+ else
+ ((scm_thread *)SCM_THREAD_DATA(thread))->exited = 1;
+
+ /* Return to old dynamic context. */
+ scm_dowinds (old_winds, - scm_ilength (old_winds));
+
+ if (err)
+ {
+ errno = err;
+ scm_syserror ("create-thread");
+ }
+ }
+
+ return thread;
+}
+
+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, "
+"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. "
+"If this happens, the error-thunk is called outside the scope of the new "
+"root -- it is called in the same dynamic context in which "
+"with-new-thread was evaluated, but not in the callers thread. "
+"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,
+ FUNC_NAME);
+
+ return create_thread ((scm_t_catch_body) scm_call_0, thunk,
+ (scm_t_catch_handler) scm_apply_1, handler,
+ scm_cons (thunk, handler));
+}
+#undef FUNC_NAME
+
+SCM
+scm_spawn_thread (scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data)
+{
+ return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F);
+}
+
+SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
+ (SCM thread),
+"Suspend execution of the calling thread until the target @var{thread} "
+"terminates, unless the target @var{thread} has already terminated. ")
+#define FUNC_NAME s_scm_join_thread
+{
+ scm_thread *t;
+ SCM res;
+
+ SCM_VALIDATE_THREAD (1, thread);
+ if (SCM_EQ_P (cur_thread, thread))
+ SCM_MISC_ERROR ("can not join the current thread", SCM_EOL);
+
+ t = SCM_THREAD_DATA (thread);
+ if (!t->exited)
+ {
+ scm_thread *c = leave_guile ();
+ scm_thread_join (t->thread);
+ enter_guile (c);
+ }
+ res = t->result;
+ t->result = SCM_BOOL_F;
+ return res;
+}
+#undef FUNC_NAME
+
+/*** Mutexes */
+
+/* We implement our own mutex type since we want them to be 'fair', we
+ want to do fancy things while waiting for them (like running
+ asyncs) and we want to support waiting on many things at once.
+ Also, we might add things that are nice for debugging.
+*/
+
+typedef struct scm_mutex {
+ /* the thread currently owning the mutex, or SCM_BOOL_F. */
+ SCM owner;
+ /* how much the owner owns us. */
+ int level;
+ /* the threads waiting for this mutex. */
+ SCM waiting;
+} scm_mutex;
+
+static SCM
+mutex_mark (SCM mx)
+{
+ scm_mutex *m = SCM_MUTEX_DATA (mx);
+ scm_gc_mark (m->owner);
+ return m->waiting;
+}
+
+SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0,
+ (void),
+ "Create a new mutex object. ")
+#define FUNC_NAME s_scm_make_mutex
+{
+ SCM mx = scm_make_smob (scm_tc16_mutex);
+ scm_mutex *m = SCM_MUTEX_DATA (mx);
+ m->owner = SCM_BOOL_F;
+ m->level = 0;
+ m->waiting = make_queue ();
+ return mx;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
+ (SCM mx),
+"Lock @var{mutex}. If the mutex is already locked, the calling thread "
+"blocks until the mutex becomes available. The function returns when "
+"the calling thread owns the lock on @var{mutex}. Locking a mutex that "
+"a thread already owns will succeed right away and will not block the "
+"thread. That is, Guile's mutexes are @emph{recursive}. ")
+#define FUNC_NAME s_scm_lock_mutex
+{
+ scm_mutex *m;
+ SCM_VALIDATE_MUTEX (1, mx);
+ m = SCM_MUTEX_DATA (mx);
+
+ if (m->owner == SCM_BOOL_F)
+ m->owner = cur_thread;
+ else if (m->owner == cur_thread)
+ m->level++;
+ else
+ {
+ while (1)
+ {
+ SCM c = enqueue (m->waiting, cur_thread);
+ int err = block ();
+ if (m->owner == cur_thread)
+ return SCM_BOOL_T;
+ remqueue (m->waiting, c);
+ if (err)
+ {
+ errno = err;
+ scm_syserror (FUNC_NAME);
+ }
+ SCM_ASYNC_TICK;
+ }
+ }
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0,
+ (SCM mx),
+"Try to lock @var{mutex}. If the mutex is already locked by someone "
+"else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
+#define FUNC_NAME s_scm_try_mutex
+{
+ scm_mutex *m;
+ SCM_VALIDATE_MUTEX (1, mx);
+ m = SCM_MUTEX_DATA (mx);
+
+ if (m->owner == SCM_BOOL_F)
+ m->owner = cur_thread;
+ else if (m->owner == cur_thread)
+ m->level++;
+ else
+ return SCM_BOOL_F;
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0,
+ (SCM mx),
+"Unlocks @var{mutex} if the calling thread owns the lock on "
+"@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
+"thread results in undefined behaviour. Once a mutex has been unlocked, "
+"one thread blocked on @var{mutex} is awakened and grabs the mutex "
+"lock. Every call to @code{lock-mutex} by this thread must be matched "
+"with a call to @code{unlock-mutex}. Only the last call to "
+"@code{unlock-mutex} will actually unlock the mutex. ")
+#define FUNC_NAME s_scm_unlock_mutex
+{
+ scm_mutex *m;
+ SCM_VALIDATE_MUTEX (1, mx);
+ m = SCM_MUTEX_DATA (mx);
+
+ if (m->owner != cur_thread)
+ {
+ if (m->owner == SCM_BOOL_F)
+ SCM_MISC_ERROR ("mutex not locked", SCM_EOL);
+ else
+ SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL);
+ }
+ else if (m->level > 0)
+ m->level--;
+ else
+ {
+ SCM next = dequeue (m->waiting);
+ if (!SCM_FALSEP (next))
+ {
+ m->owner = next;
+ unblock (SCM_THREAD_DATA (next));
+ scm_yield ();
+ }
+ else
+ m->owner = SCM_BOOL_F;
+ }
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+/*** Condition variables */
+
+/* Like mutexes, we implement our own condition variables using the
+ primitives above.
+*/
+
+/* yeah, we don't need a structure for this, but more things (like a
+ name) will likely follow... */
+
+typedef struct scm_cond {
+ /* the threads waiting for this condition. */
+ SCM waiting;
+} scm_cond;
+
+static SCM
+cond_mark (SCM cv)
+{
+ scm_cond *c = SCM_CONDVAR_DATA (cv);
+ return c->waiting;
+}
+
+SCM_DEFINE (scm_make_condition_variable, "make-condition-variable", 0, 0, 0,
+ (void),
+ "Make a new condition variable.")
+#define FUNC_NAME s_scm_make_condition_variable
+{
+ SCM cv = scm_make_smob (scm_tc16_condvar);
+ scm_cond *c = SCM_CONDVAR_DATA (cv);
+ c->waiting = make_queue ();
+ return cv;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, 0,
+ (SCM cv, SCM mx, SCM t),
+"Wait until @var{cond-var} has been signalled. While waiting, "
+"@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
+"is locked again when this function returns. When @var{time} is given, "
+"it specifies a point in time where the waiting should be aborted. It "
+"can be either a integer as returned by @code{current-time} or a pair "
+"as returned by @code{gettimeofday}. When the waiting is aborted the "
+"mutex is locked and @code{#f} is returned. When the condition "
+"variable is in fact signalled, the mutex is also locked and @code{#t} "
+"is returned. ")
+#define FUNC_NAME s_scm_timed_wait_condition_variable
+{
+ scm_cond *c;
+ struct timespec waittime;
+ int err;
+
+ SCM_VALIDATE_CONDVAR (1, cv);
+ SCM_VALIDATE_MUTEX (2, mx);
+
+ if (!SCM_UNBNDP (t))
+ {
+ if (SCM_CONSP (t))
+ {
+ SCM_VALIDATE_UINT_COPY (3, SCM_CAR(t), waittime.tv_sec);
+ SCM_VALIDATE_UINT_COPY (3, SCM_CDR(t), waittime.tv_nsec);
+ waittime.tv_nsec *= 1000;
+ }
+ else
+ {
+ SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec);
+ waittime.tv_nsec = 0;
+ }
+ }
+
+ c = SCM_CONDVAR_DATA (cv);
+
+ while (1)
+ {
+ enqueue (c->waiting, cur_thread);
+ scm_unlock_mutex (mx);
+ if (SCM_UNBNDP (t))
+ err = block ();
+ else
+ err = timed_block (&waittime);
+ scm_lock_mutex (mx);
+ if (err)
+ {
+ errno = err;
+ scm_syserror (FUNC_NAME);
+ }
+ /* XXX - check whether we have been signalled. */
+ break;
+ }
+ return SCM_BOOL (err == 0);
+}
+#undef FUNC_NAME
+
+SCM
+scm_wait_condition_variable (SCM c, SCM m)
+{
+ return scm_timed_wait_condition_variable (c, m, SCM_UNDEFINED);
+}
+
+SCM_DEFINE (scm_signal_condition_variable, "signal-condition-variable", 1, 0, 0,
+ (SCM cv),
+ "Wake up one thread that is waiting for @var{cv}")
+#define FUNC_NAME s_scm_signal_condition_variable
+{
+ SCM th;
+ scm_cond *c;
+
+ SCM_VALIDATE_CONDVAR (1, cv);
+
+ c = SCM_CONDVAR_DATA (cv);
+ if (!SCM_FALSEP (th = dequeue (c->waiting)))
+ unblock (SCM_THREAD_DATA (th));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1, 0, 0,
+ (SCM cv),
+ "Wake up all threads that are waiting for @var{cv}. ")
+#define FUNC_NAME s_scm_broadcast_condition_variable
+{
+ SCM th;
+ scm_cond *c;
+
+ SCM_VALIDATE_CONDVAR (1, cv);
+
+ c = SCM_CONDVAR_DATA (cv);
+ while (!SCM_FALSEP (th = dequeue (c->waiting)))
+ unblock (SCM_THREAD_DATA (th));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+/*** Marking stacks */
+
+/* XXX - what to do with this? Do we need to handle this for blocked
+ threads as well?
+*/
+#ifdef __ia64__
+# define SCM_MARK_BACKING_STORE() do { \
+ ucontext_t ctx; \
+ SCM_STACKITEM * top, * bot; \
+ getcontext (&ctx); \
+ scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
+ ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
+ / sizeof (SCM_STACKITEM))); \
+ bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
+ top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
+ scm_mark_locations (bot, top - bot); } while (0)
+#else
+# define SCM_MARK_BACKING_STORE()
+#endif
+
+void
+scm_threads_mark_stacks (void)
+{
+ volatile SCM c;
+ for (c = all_threads; !SCM_NULLP (c); c = SCM_CDR (c))
+ {
+ scm_thread *t = SCM_THREAD_DATA (SCM_CAR (c));
+ if (t->base == NULL)
+ {
+ /* Not fully initialized yet. */
+ continue;
+ }
+ if (t->top == NULL)
+ {
+ /* Active thread */
+ /* stack_len is long rather than sizet in order to guarantee
+ that &stack_len is long aligned */
+#ifdef STACK_GROWS_UP
+ long 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.
+ */
+ 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
+ long 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
+ }
+ else
+ {
+ /* Suspended thread */
+#ifdef STACK_GROWS_UP
+ long stack_len = t->top - t->base;
+ scm_mark_locations (t->base, stack_len);
+#else
+ long stack_len = t->base - t->top;
+ scm_mark_locations (t->top, stack_len);
+#endif
+ scm_mark_locations ((SCM_STACKITEM *) t->regs,
+ ((size_t) sizeof(t->regs)
+ / sizeof (SCM_STACKITEM)));
+ }
+ }
+}
+
+/*** Select */
+
+int
+scm_internal_select (int nfds,
+ SELECT_TYPE *readfds,
+ SELECT_TYPE *writefds,
+ SELECT_TYPE *exceptfds,
+ struct timeval *timeout)
+{
+ int res, eno;
+ scm_thread *c = leave_guile ();
+ res = scm_thread_select (nfds, readfds, writefds, exceptfds, timeout);
+ eno = errno;
+ enter_guile (c);
+ SCM_ASYNC_TICK;
+ errno = eno;
+ return res;
+}
+
+unsigned long
+scm_thread_usleep (unsigned long usecs)
+{
+ struct timeval tv;
+ tv.tv_usec = usecs % 1000000;
+ tv.tv_sec = usecs / 1000000;
+ scm_internal_select (0, NULL, NULL, NULL, &tv);
+ return tv.tv_usec + tv.tv_sec*1000000;
+}
+
+unsigned long
+scm_thread_sleep (unsigned long secs)
+{
+ struct timeval tv;
+ tv.tv_usec = 0;
+ tv.tv_sec = secs;
+ scm_internal_select (0, NULL, NULL, NULL, &tv);
+ return tv.tv_sec;
+}
+
+/*** Misc */
+
+SCM_DEFINE (scm_current_thread, "current-thread", 0, 0, 0,
+ (void),
+ "Return the thread that called this function.")
+#define FUNC_NAME s_scm_current_thread
+{
+ return cur_thread;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0,
+ (void),
+ "Return a list of all threads.")
+#define FUNC_NAME s_all_threads
+{
+ return all_threads;
+}
+#undef FUNC_NAME
+
+scm_root_state *
+scm_i_thread_root (SCM thread)
+{
+ return ((scm_thread *)SCM_THREAD_DATA (thread))->root;
+}
+
+SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0,
+ (SCM thread),
+ "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));
+}
+#undef FUNC_NAME
+
+int
+scm_c_thread_exited_p (SCM thread)
+#define FUNC_NAME s_scm_thread_exited_p
+{
+ scm_thread *t;
+ SCM_VALIDATE_THREAD (1, thread);
+ t = SCM_THREAD_DATA (thread);
+ return t->exited;
+}
+#undef FUNC_NAME
+
+/*** Initialization */
+
+scm_t_bits scm_tc16_thread;
+scm_t_bits scm_tc16_mutex;
+scm_t_bits scm_tc16_condvar;
+
+void
+scm_init_threads (SCM_STACKITEM *base)
+{
+ scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_thread));
+ scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_mutex));
+ scm_tc16_condvar = scm_make_smob_type ("condition-variable",
+ sizeof (scm_cond));
+
+ scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT;
+
+ fair_mutex_init (&guile_mutex);
+
+ cur_thread = make_thread (SCM_BOOL_F);
+ enter_guile (SCM_THREAD_DATA (cur_thread));
+ /* root is set later from init.c */
+ init_thread_creator (cur_thread, scm_thread_self(), NULL);
+ init_thread_creatant (cur_thread, base);
+
+ thread_count = 1;
+ scm_gc_register_root (&all_threads);
+ all_threads = scm_cons (cur_thread, SCM_EOL);
+
+ scm_set_smob_mark (scm_tc16_thread, thread_mark);
+ scm_set_smob_print (scm_tc16_thread, thread_print);
+ scm_set_smob_free (scm_tc16_thread, thread_free);
+
+ scm_set_smob_mark (scm_tc16_mutex, mutex_mark);
+
+ scm_set_smob_mark (scm_tc16_condvar, cond_mark);
+}
+
+void
+scm_init_thread_procs ()
+{
+#include "libguile/threads.x"
+}
+
+/* XXX */
+
+void
+scm_init_iselect ()
+{
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
+
HCoop / bpt / guile.git / commitdiff