diff options
author | Ludovic Courtès <ludo@gnu.org> | 2009-01-18 12:53:01 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2009-01-18 21:05:02 +0100 |
commit | 32a2609de06af65341e6b4db6961557b788821e8 (patch) | |
tree | 320547be1ac5ba11d544dc1598006a55bc322933 /libguile/coop-pthreads.c | |
parent | e95d11110b7af0f528404d28209c3a464ab7074d (diff) | |
download | guile-32a2609de06af65341e6b4db6961557b788821e8.tar.gz |
Remove useless cooperative multi-threading source files.
Diffstat (limited to 'libguile/coop-pthreads.c')
-rw-r--r-- | libguile/coop-pthreads.c | 1040 |
1 files changed, 0 insertions, 1040 deletions
diff --git a/libguile/coop-pthreads.c b/libguile/coop-pthreads.c deleted file mode 100644 index b1759f9ed..000000000 --- a/libguile/coop-pthreads.c +++ /dev/null @@ -1,1040 +0,0 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006 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 as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * 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. - * - * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - - - - -#include "libguile/_scm.h" /* config.h, _scm.h, __scm.h should be first */ - -#include <unistd.h> -#include <stdio.h> -#include <assert.h> -#include <sys/time.h> - -#include "libguile/validate.h" -#include "libguile/coop-pthreads.h" -#include "libguile/root.h" -#include "libguile/eval.h" -#include "libguile/async.h" -#include "libguile/ports.h" -#include "libguile/gc.h" - -#undef DEBUG - -/*** Queues */ - -static SCM -make_queue () -{ - return scm_cons (SCM_EOL, SCM_EOL); -} - -static void -enqueue (SCM q, SCM t) -{ - SCM c = scm_cons (t, SCM_EOL); - if (scm_is_null (SCM_CAR (q))) - SCM_SETCAR (q, c); - else - SCM_SETCDR (SCM_CDR (q), c); - SCM_SETCDR (q, c); -} - -static SCM -dequeue (SCM q) -{ - SCM c = SCM_CAR (q); - if (scm_is_null (c)) - return SCM_BOOL_F; - else - { - SCM_SETCAR (q, SCM_CDR (c)); - if (scm_is_null (SCM_CAR (q))) - SCM_SETCDR (q, SCM_EOL); - return SCM_CAR (c); - } -} - - -/*** Threads */ - -typedef struct scm_copt_thread { - - /* A condition variable for sleeping on. - */ - pthread_cond_t sleep_cond; - - /* A link for waiting queues. - */ - struct scm_copt_thread *next_waiting; - - scm_root_state *root; - SCM handle; - pthread_t pthread; - SCM result; - - SCM joining_threads; - - /* For keeping track of the stack and registers. */ - SCM_STACKITEM *base; - SCM_STACKITEM *top; - jmp_buf regs; - -} scm_copt_thread; - -static SCM -make_thread (SCM creation_protects) -{ - SCM z; - scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread"); - z = scm_cell (scm_tc16_thread, (scm_t_bits)t); - t->handle = z; - t->result = creation_protects; - t->base = NULL; - t->joining_threads = make_queue (); - pthread_cond_init (&t->sleep_cond, NULL); - return z; -} - -static void -init_thread_creator (SCM thread, pthread_t th, scm_root_state *r) -{ - scm_copt_thread *t = SCM_THREAD_DATA(thread); - t->root = r; - t->pthread = th; -#ifdef DEBUG - // fprintf (stderr, "%ld created %ld\n", pthread_self (), th); -#endif -} - -static void -init_thread_creatant (SCM thread, SCM_STACKITEM *base) -{ - scm_copt_thread *t = SCM_THREAD_DATA(thread); - t->base = base; - t->top = NULL; -} - -static SCM -thread_mark (SCM obj) -{ - scm_copt_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_copt_thread *t = SCM_THREAD_DATA (exp); - scm_puts ("#<thread ", port); - scm_uintprint ((scm_t_bits)t, 16, port); - if (t->pthread != -1) - { - scm_putc (' ', port); - scm_intprint (t->pthread, 10, port); - } - else - scm_puts (" (exited)", port); - scm_putc ('>', port); - return 1; -} - -static size_t -thread_free (SCM obj) -{ - scm_copt_thread *t = SCM_THREAD_DATA (obj); - if (t->pthread != -1) - abort (); - scm_gc_free (t, sizeof (*t), "thread"); - return 0; -} - -/*** Fair mutexes */ - -/* 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 POSIX. -*/ - -typedef struct fair_mutex { - pthread_mutex_t lock; - scm_copt_thread *owner; - scm_copt_thread *next_waiting, *last_waiting; -} fair_mutex; - -static void -fair_mutex_init (fair_mutex *m) -{ - pthread_mutex_init (&m->lock, NULL); - m->owner = NULL; - m->next_waiting = NULL; - m->last_waiting = NULL; -} - -static void -fair_mutex_lock_1 (fair_mutex *m, scm_copt_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 - { - pthread_cond_wait (&t->sleep_cond, &m->lock); - } - while (m->owner != t); - assert (m->next_waiting == t); - m->next_waiting = t->next_waiting; - if (m->next_waiting == NULL) - m->last_waiting = NULL; - } - pthread_mutex_unlock (&m->lock); -} - -static void -fair_mutex_lock (fair_mutex *m, scm_copt_thread *t) -{ - pthread_mutex_lock (&m->lock); - fair_mutex_lock_1 (m, t); -} - -static void -fair_mutex_unlock_1 (fair_mutex *m) -{ - scm_copt_thread *t; - pthread_mutex_lock (&m->lock); - // fprintf (stderr, "%ld unlocking\n", m->owner->pthread); - if ((t = m->next_waiting) != NULL) - { - m->owner = t; - pthread_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); - pthread_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. -*/ -#if 0 -static void -fair_mutex_yield (fair_mutex *m) -{ - scm_copt_thread *self, *next; - - pthread_mutex_lock (&m->lock); - - /* get next thread - */ - if ((next = m->next_waiting) == NULL) - { - /* No use giving it up. */ - pthread_mutex_unlock (&m->lock); - return; - } - - /* put us on queue - */ - self = m->owner; - self->next_waiting = NULL; - if (m->last_waiting) - m->last_waiting->next_waiting = self; - else - m->next_waiting = self; - m->last_waiting = self; - - /* wake up next thread - */ - - m->owner = next; - pthread_cond_signal (&next->sleep_cond); - - /* wait for mutex - */ - do - { - pthread_cond_wait (&self->sleep_cond, &m->lock); - } - while (m->owner != self); - assert (m->next_waiting == self); - m->next_waiting = self->next_waiting; - if (m->next_waiting == NULL) - m->last_waiting = NULL; - - pthread_mutex_unlock (&m->lock); -} -#else -static void -fair_mutex_yield (fair_mutex *m) -{ - scm_copt_thread *self = m->owner; - fair_mutex_unlock_1 (m); - fair_mutex_lock_1 (m, self); -} -#endif - -static void -fair_cond_wait (pthread_cond_t *c, fair_mutex *m) -{ - scm_copt_thread *t = m->owner; - fair_mutex_unlock_1 (m); - pthread_cond_wait (c, &m->lock); - fair_mutex_lock_1 (m, t); -} - -/* Return 1 when the mutex was signalled and 0 when not. */ -static int -fair_cond_timedwait (pthread_cond_t *c, fair_mutex *m, scm_t_timespec *at) -{ - int res; - scm_copt_thread *t = m->owner; - fair_mutex_unlock_1 (m); - res = pthread_cond_timedwait (c, &m->lock, at); /* XXX - signals? */ - fair_mutex_lock_1 (m, t); - return res == 0; -} - -/*** 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_copt_thread_data; - -void -scm_i_copt_set_thread_data (void *data) -{ - scm_copt_thread *t = SCM_THREAD_DATA (cur_thread); - scm_i_copt_thread_data = data; - t->root = (scm_root_state *)data; -} - -static void -resume (scm_copt_thread *t) -{ - cur_thread = t->handle; - scm_i_copt_thread_data = t->root; - t->top = NULL; -} - -static void -enter_guile (scm_copt_thread *t) -{ - fair_mutex_lock (&guile_mutex, t); - resume (t); -} - -static scm_copt_thread * -suspend () -{ - SCM cur = cur_thread; - scm_copt_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_copt_thread * -leave_guile () -{ - scm_copt_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_copt_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 void -block () -{ - scm_copt_thread *t = suspend (); - fair_cond_wait (&t->sleep_cond, &guile_mutex); - resume (t); -} - -/* 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 1 when it has been unblocked; 0 otherwise. - */ -static int -timed_block (scm_t_timespec *at) -{ - int res; - scm_copt_thread *t = suspend (); - res = fair_cond_timedwait (&t->sleep_cond, &guile_mutex, at); - resume (t); - return res; -} - -/* Unblock a sleeping thread. - */ -static void -unblock (scm_copt_thread *t) -{ - pthread_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); - // return scm_call_0 (data->body); -} - -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); - // return scm_apply_1 (data->handler, tag, throw_args); -} - -static void -really_launch (SCM_STACKITEM *base, launch_data *data) -{ - SCM thread = data->thread; - scm_copt_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); - - pthread_detach (t->pthread); - all_threads = scm_delq (thread, all_threads); - t->pthread = -1; - thread_count--; - leave_guile (); -} - -static void * -launch_thread (void *p) -{ - really_launch ((SCM_STACKITEM *)&p, (launch_data *)p); - return NULL; -} - -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. - */ - - { - pthread_t th; - SCM root, old_winds; - launch_data *data; - - /* 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; - pthread_create (&th, NULL, launch_thread, (void *) data); - init_thread_creator (thread, th, SCM_ROOT_STATE (root)); - all_threads = scm_cons (thread, all_threads); - thread_count++; - - /* Return to old dynamic context. */ - scm_dowinds (old_winds, - scm_ilength (old_winds)); - } - - return thread; -} - -SCM -scm_call_with_new_thread (SCM argl) -#define FUNC_NAME s_call_with_new_thread -{ - SCM thunk, handler; - - /* Check arguments. */ - { - register SCM args = argl; - if (!scm_is_pair (args)) - SCM_WRONG_NUM_ARGS (); - thunk = SCM_CAR (args); - SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), - thunk, - SCM_ARG1, - s_call_with_new_thread); - args = SCM_CDR (args); - if (!scm_is_pair (args)) - SCM_WRONG_NUM_ARGS (); - handler = SCM_CAR (args); - SCM_ASSERT (scm_is_true (scm_procedure_p (handler)), - handler, - SCM_ARG2, - s_call_with_new_thread); - if (!scm_is_null (SCM_CDR (args))) - SCM_WRONG_NUM_ARGS (); - } - - return create_thread ((scm_t_catch_body) scm_call_0, thunk, - (scm_t_catch_handler) scm_apply_1, handler, - argl); -} -#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); -} - -/*** 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_copt_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_copt_mutex; - -static SCM -mutex_mark (SCM mx) -{ - scm_copt_mutex *m = SCM_MUTEX_DATA (mx); - scm_gc_mark (m->owner); - return m->waiting; -} - -SCM -scm_make_mutex () -{ - SCM mx = scm_make_smob (scm_tc16_mutex); - scm_copt_mutex *m = SCM_MUTEX_DATA (mx); - m->owner = SCM_BOOL_F; - m->level = 0; - m->waiting = make_queue (); - return mx; -} - -SCM -scm_lock_mutex (SCM mx) -#define FUNC_NAME s_lock_mutex -{ - scm_copt_mutex *m; - SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME); - 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 (m->owner != cur_thread) - { - enqueue (m->waiting, cur_thread); - block (); - SCM_ASYNC_TICK; - } - } - return SCM_BOOL_T; -} -#undef FUNC_NAME - -SCM -scm_try_mutex (SCM mx) -#define FUNC_NAME s_try_mutex -{ - scm_copt_mutex *m; - SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME); - 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 -scm_unlock_mutex (SCM mx) -#define FUNC_NAME s_unlock_mutex -{ - scm_copt_mutex *m; - SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME); - 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_is_true (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_copt_cond { - /* the threads waiting for this condition. */ - SCM waiting; -} scm_copt_cond; - -static SCM -cond_mark (SCM cv) -{ - scm_copt_cond *c = SCM_CONDVAR_DATA (cv); - return c->waiting; -} - -SCM -scm_make_condition_variable (void) -{ - SCM cv = scm_make_smob (scm_tc16_condvar); - scm_copt_cond *c = SCM_CONDVAR_DATA (cv); - c->waiting = make_queue (); - return cv; -} - -SCM -scm_timed_wait_condition_variable (SCM cv, SCM mx, SCM t) -#define FUNC_NAME s_wait_condition_variable -{ - scm_copt_cond *c; - scm_t_timespec waittime; - int res; - - SCM_ASSERT (SCM_CONDVARP (cv), - cv, - SCM_ARG1, - s_wait_condition_variable); - SCM_ASSERT (SCM_MUTEXP (mx), - mx, - SCM_ARG2, - s_wait_condition_variable); - if (!SCM_UNBNDP (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); - waittime.tv_nsec *= 1000; - } - else - { - SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec); - waittime.tv_nsec = 0; - } - } - - c = SCM_CONDVAR_DATA (cv); - - enqueue (c->waiting, cur_thread); - scm_unlock_mutex (mx); - if (SCM_UNBNDP (t)) - { - block (); - res = 1; - } - else - res = timed_block (&waittime); - scm_lock_mutex (mx); - return scm_from_bool (res); -} -#undef FUNC_NAME - -SCM -scm_signal_condition_variable (SCM cv) -#define FUNC_NAME s_signal_condition_variable -{ - SCM th; - scm_copt_cond *c; - SCM_ASSERT (SCM_CONDVARP (cv), - cv, - SCM_ARG1, - s_signal_condition_variable); - c = SCM_CONDVAR_DATA (cv); - if (scm_is_true (th = dequeue (c->waiting))) - unblock (SCM_THREAD_DATA (th)); - return SCM_BOOL_T; -} -#undef FUNC_NAME - -SCM -scm_broadcast_condition_variable (SCM cv) -#define FUNC_NAME s_broadcast_condition_variable -{ - SCM th; - scm_copt_cond *c; - SCM_ASSERT (SCM_CONDVARP (cv), - cv, - SCM_ARG1, - s_signal_condition_variable); - c = SCM_CONDVAR_DATA (cv); - while (scm_is_true (th = dequeue (c->waiting))) - unblock (SCM_THREAD_DATA (th)); - return SCM_BOOL_T; -} -#undef FUNC_NAME - -/*** Initialization */ - -void -scm_threads_init (SCM_STACKITEM *base) -{ - scm_tc16_thread = scm_make_smob_type ("thread", 0); - scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_copt_mutex)); - scm_tc16_condvar = scm_make_smob_type ("condition-variable", - sizeof (scm_copt_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, pthread_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); -} - -/*** 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 *) scm_ia64_register_backing_store_base (); \ - top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \ - 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_is_null (c); c = SCM_CDR (c)) - { - scm_copt_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 */ -#if SCM_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 */ -#if SCM_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_copt_thread *c = leave_guile (); - res = select (nfds, readfds, writefds, exceptfds, timeout); - eno = errno; - enter_guile (c); - SCM_ASYNC_TICK; - errno = eno; - return res; -} - -void -scm_init_iselect () -{ -} - -unsigned long -scm_thread_usleep (unsigned long usec) -{ - scm_copt_thread *c = leave_guile (); - usleep (usec); - enter_guile (c); - return 0; -} - -unsigned long -scm_thread_sleep (unsigned long sec) -{ - unsigned long res; - scm_copt_thread *c = leave_guile (); - res = sleep (sec); - enter_guile (c); - return res; -} - -/*** Misc */ - -SCM -scm_current_thread (void) -{ - return cur_thread; -} - -SCM -scm_all_threads (void) -{ - return all_threads; -} - -scm_root_state * -scm_i_thread_root (SCM thread) -{ - if (thread == cur_thread) - return scm_i_copt_thread_data; - else - return ((scm_copt_thread *)SCM_THREAD_DATA (thread))->root; -} - -SCM -scm_join_thread (SCM thread) -#define FUNC_NAME s_join_thread -{ - scm_copt_thread *t; - SCM res; - - SCM_VALIDATE_THREAD (1, thread); - - t = SCM_THREAD_DATA (thread); - if (t->pthread != -1) - { - scm_copt_thread *c = leave_guile (); - pthread_join (t->pthread, NULL); - enter_guile (c); - } - res = t->result; - t->result = SCM_BOOL_F; - return res; -} -#undef FUNC_NAME - -int -scm_c_thread_exited_p (SCM thread) -#define FUNC_NAME s_scm_thread_exited_p -{ - scm_copt_thread *t; - SCM_VALIDATE_THREAD (1, thread); - t = SCM_THREAD_DATA (thread); - return t->pthread == -1; -} -#undef FUNC_NAME - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ - |