diff --git a/libguile/threads.c b/libguile/threads.c index 196660d18..d36d3bcc7 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2002 Free Software Foundation, Inc. +/* 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 @@ -42,74 +42,991 @@ -/* 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 - - - * second #inclusion +/* This file implements nice Scheme level threads on top of the gastly + C level threads. */ -#include +#include +#include +#include +#include #include "libguile/_scm.h" -#include "libguile/dynwind.h" -#include "libguile/smob.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 */ -scm_t_bits scm_tc16_thread; -scm_t_bits scm_tc16_mutex; -scm_t_bits scm_tc16_condvar; +static SCM +make_queue () +{ + return scm_cons (SCM_EOL, SCM_EOL); +} - -/* Scheme-visible thread functions. */ +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; +} -#ifdef USE_COOP_THREADS -SCM_REGISTER_PROC(s_single_thread_p, "single-active-thread?", 0, 0, 0, scm_single_thread_p); +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 ("#', 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 -/* GJB:FIXME:DOC: SCM_REGISTER_PROC needs to permit a docstring, - or these need to move into the file where the proc is defined. */ +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))); + } + } +} -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. -*/ +/*** Select */ -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. +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; +} -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. +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; +} -All the evaluation rules for dynamic roots apply to threads. -*/ +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; +} -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); +/*** Misc */ -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_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), @@ -120,141 +1037,52 @@ SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0, } #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); -} - - - -#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 - - - -#if (SCM_ENABLE_DEPRECATED == 1) - int -scm_mutex_init (scm_t_mutex *m) +scm_c_thread_exited_p (SCM thread) +#define FUNC_NAME s_scm_thread_exited_p { - scm_gc_protect_object (m->m = scm_make_mutex ()); - return 0; + scm_thread *t; + SCM_VALIDATE_THREAD (1, thread); + t = SCM_THREAD_DATA (thread); + return t->exited; } +#undef FUNC_NAME -int -scm_mutex_lock (scm_t_mutex *m) -{ - scm_lock_mutex (m->m); - return 0; -} +/*** Initialization */ -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 - - +scm_t_bits scm_tc16_thread; +scm_t_bits scm_tc16_mutex; +scm_t_bits scm_tc16_condvar; void -scm_init_threads (SCM_STACKITEM *i) +scm_init_threads (SCM_STACKITEM *base) { - /* Initialize implementation specific details of the threads support */ - scm_threads_init (i); + 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 @@ -263,8 +1091,16 @@ scm_init_thread_procs () #include "libguile/threads.x" } +/* XXX */ + +void +scm_init_iselect () +{ +} + /* Local Variables: c-file-style: "gnu" End: */ + diff --git a/libguile/threads.h b/libguile/threads.h index 965326e00..df83f75c8 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -50,7 +50,7 @@ #include "libguile/procs.h" #include "libguile/throw.h" #include "libguile/root.h" - +#include "libguile/iselect.h" /* smob tags for the thread datatypes */ @@ -67,8 +67,15 @@ SCM_API scm_t_bits scm_tc16_condvar; #define SCM_CONDVARP(x) SCM_TYP16_PREDICATE (scm_tc16_condvar, x) #define SCM_CONDVAR_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) -/* Initialize implementation specific details of the threads support */ -SCM_API void scm_threads_init (SCM_STACKITEM *); +#define SCM_VALIDATE_THREAD(pos, a) \ + SCM_MAKE_VALIDATE_MSG (pos, a, THREADP, "thread") + +#define SCM_VALIDATE_MUTEX(pos, a) \ + SCM_MAKE_VALIDATE_MSG (pos, a, MUTEXP, "mutex") + +#define SCM_VALIDATE_CONDVAR(pos, a) \ + SCM_MAKE_VALIDATE_MSG (pos, a, CONDVARP, "condition variable") + SCM_API void scm_threads_mark_stacks (void); SCM_API void scm_init_threads (SCM_STACKITEM *); SCM_API void scm_init_thread_procs (void); @@ -76,18 +83,39 @@ SCM_API void scm_init_thread_procs (void); SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data); -/* These are versions of the ordinary sleep and usleep functions, +/* These are versions of the ordinary sleep and usleep functions that play nicely with the thread system. */ SCM_API unsigned long scm_thread_sleep (unsigned long); SCM_API unsigned long scm_thread_usleep (unsigned long); +/* Critical sections */ + +/* Since only one thread can be active anyway, we don't need to do + anything special around critical sections. In fact, that's the + reason we do only support cooperative threading: Guile's critical + regions have not been completely identified yet. (I think.) */ + +#define SCM_CRITICAL_SECTION_START +#define SCM_CRITICAL_SECTION_END + +/* Switching */ + +SCM_API int scm_i_switch_counter; +#define SCM_I_THREAD_SWITCH_COUNT 50 + +#define SCM_THREAD_SWITCHING_CODE \ +do { \ + scm_i_switch_counter--; \ + if (scm_i_switch_counter == 0) \ + { \ + scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT; \ + scm_yield(); \ + } \ +} while (0) /* The C versions of the Scheme-visible thread functions. */ -#ifdef USE_COOP_THREADS -SCM_API SCM scm_single_thread_p (void); -#endif SCM_API SCM scm_yield (void); -SCM_API SCM scm_call_with_new_thread (SCM argl); +SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler); SCM_API SCM scm_join_thread (SCM t); SCM_API SCM scm_make_mutex (void); SCM_API SCM scm_lock_mutex (SCM m); @@ -108,6 +136,11 @@ SCM_API SCM scm_thread_exited_p (SCM thread); SCM_API scm_root_state *scm_i_thread_root (SCM thread); +SCM_API void *scm_i_thread_data; +SCM_API void scm_i_set_thread_data (void *); +#define SCM_THREAD_LOCAL_DATA scm_i_thread_data +#define SCM_SET_THREAD_LOCAL_DATA(x) scm_i_set_thread_data(x) + #ifndef HAVE_STRUCT_TIMESPEC /* POSIX.4 structure for a time value. This is like a `struct timeval' but has nanoseconds instead of microseconds. */ @@ -118,41 +151,11 @@ struct timespec }; #endif -#ifdef USE_COOP_THREADS -#include "libguile/coop-defs.h" -#else #ifdef USE_COPT_THREADS -#include "libguile/coop-pthreads.h" +#include "libguile/pthread-threads.h" #else #include "libguile/null-threads.h" #endif -#endif - -#if (SCM_ENABLE_DEPRECATED == 1) - -typedef struct { - SCM m; -} scm_t_mutex; - -SCM_API int scm_mutex_init (scm_t_mutex *m); -SCM_API int scm_mutex_lock (scm_t_mutex *m); -SCM_API int scm_mutex_trylock (scm_t_mutex *m); -SCM_API int scm_mutex_unlock (scm_t_mutex *m); -SCM_API int scm_mutex_destroy (scm_t_mutex *m); - -typedef struct { - SCM c; -} scm_t_cond; - -SCM_API int scm_cond_init (scm_t_cond *c, int *cattr); -SCM_API int scm_cond_wait (scm_t_cond *c, scm_t_mutex *m); -SCM_API int scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m, - const struct timespec *abstime); -SCM_API int scm_cond_signal (scm_t_cond *c); -SCM_API int scm_cond_broadcast (scm_t_cond *c); -SCM_API int scm_cond_destroy (scm_t_cond *c); - -#endif /* SCM_ENABLE_DEPRECATED == 1 */ #endif /* SCM_THREADS_H */