summaryrefslogtreecommitdiff
path: root/libguile/coop-pthreads.c
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2009-01-18 12:53:01 +0100
committerLudovic Courtès <ludo@gnu.org>2009-01-18 21:05:02 +0100
commit32a2609de06af65341e6b4db6961557b788821e8 (patch)
tree320547be1ac5ba11d544dc1598006a55bc322933 /libguile/coop-pthreads.c
parente95d11110b7af0f528404d28209c3a464ab7074d (diff)
downloadguile-32a2609de06af65341e6b4db6961557b788821e8.tar.gz
Remove useless cooperative multi-threading source files.
Diffstat (limited to 'libguile/coop-pthreads.c')
-rw-r--r--libguile/coop-pthreads.c1040
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:
-*/
-