-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
- */
-
-
-\f
-
-#include "libguile/_scm.h"
-#include "libguile/validate.h"
-#include "libguile/coop-threads.h"
-#include "libguile/root.h"
-
-/* A counter of the current number of threads */
-size_t scm_thread_count = 0;
-
-/* This is included rather than compiled separately in order
- to simplify the configuration mechanism. */
-#include "libguile/coop.c"
-
-/* A count-down counter used to determine when to switch
- contexts */
-size_t scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
-
-coop_m scm_critical_section_mutex;
-
-static SCM all_threads;
-
-void
-scm_threads_init (SCM_STACKITEM *i)
-{
- coop_init();
-
- scm_tc16_thread = scm_make_smob_type ("thread", 0);
- scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (coop_m));
- scm_tc16_condvar = scm_make_smob_type ("condition-variable",
- sizeof (coop_c));
-
- scm_thread_count = 1;
-
-#ifndef GUILE_PTHREAD_COMPAT
- coop_global_main.sto = i;
-#endif
- coop_global_main.base = i;
- coop_global_curr = &coop_global_main;
- coop_all_qput (&coop_global_allq, coop_global_curr);
-
- coop_mutex_init (&scm_critical_section_mutex);
-
- coop_global_main.data = 0; /* Initialized in init.c */
-
- coop_global_main.handle = scm_cell (scm_tc16_thread,
- (scm_t_bits) &coop_global_main);
-
- scm_gc_register_root (&all_threads);
- all_threads = scm_cons (coop_global_main.handle, SCM_EOL);
-}
-
-void
-scm_threads_mark_stacks (void)
-{
- coop_t *thread;
-
- for (thread = coop_global_allq.t.all_next;
- thread != NULL; thread = thread->all_next)
- {
- if (thread == coop_global_curr)
- {
- /* 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 *) (&thread) -
- (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) thread->base,
- (sizet) stack_len));
-#else
- long stack_len = ((SCM_STACKITEM *) thread->base -
- (SCM_STACKITEM *) (&thread));
-
- /* 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 *) &thread,
- stack_len);
-#endif
- }
- else
- {
- /* Suspended thread */
-#if SCM_STACK_GROWS_UP
- long stack_len = ((SCM_STACKITEM *) (thread->sp) -
- (SCM_STACKITEM *) thread->base);
-
- scm_mark_locations ((size_t)thread->base,
- (sizet) stack_len);
-#else
- long stack_len = ((SCM_STACKITEM *) thread->base -
- (SCM_STACKITEM *) (thread->sp));
-
- /* Registers are already on the stack. No need to mark. */
-
- scm_mark_locations ((SCM_STACKITEM *) (size_t)thread->sp,
- stack_len);
-#endif
- }
-
- /* Mark this thread's root */
- scm_gc_mark (((scm_root_state *) thread->data) -> handle);
- }
-}
-
-/* NOTE: There are TWO mechanisms for starting a thread: The first one
- is used when spawning a thread from Scheme, while the second one is
- used from C.
-
- It might be argued that the first should be implemented in terms of
- the second. The reason it isn't is that that would require an
- extra unnecessary malloc (the thread_args structure). By providing
- one pair of extra functions (c_launch_thread, scm_spawn_thread) the
- Scheme threads are started more efficiently. */
-
-/* This is the first thread spawning mechanism: threads from Scheme */
-
-typedef struct scheme_launch_data {
- SCM rootcont;
- SCM body;
- SCM handler;
-} scheme_launch_data;
-
-static SCM
-scheme_body_bootstrip (scheme_launch_data* data)
-{
- /* First save the new root continuation */
- data->rootcont = scm_root->rootcont;
- return scm_call_0 (data->body);
-}
-
-static SCM
-scheme_handler_bootstrip (scheme_launch_data* data, SCM tag, SCM throw_args)
-{
- scm_root->rootcont = data->rootcont;
- return scm_apply_1 (data->handler, tag, throw_args);
-}
-
-static void
-scheme_launch_thread (void *p)
-{
- /* The thread object will be GC protected by being a member of the
- list given as argument to launch_thread. It will be marked
- during the conservative sweep of the stack. */
- register SCM argl = (SCM) p;
- SCM thread = SCM_CAR (argl);
- scheme_launch_data data;
- data.rootcont = SCM_BOOL_F;
- data.body = SCM_CADR (argl);
- data.handler = SCM_CADDR (argl);
- scm_internal_cwdr ((scm_t_catch_body) scheme_body_bootstrip,
- &data,
- (scm_t_catch_handler) scheme_handler_bootstrip,
- &data,
- (SCM_STACKITEM *) &thread);
- SCM_SET_CELL_WORD_1 (thread, 0);
- scm_thread_count--;
- all_threads = scm_delq (thread, all_threads);
- SCM_DEFER_INTS;
-}
-
-
-SCM
-scm_call_with_new_thread (SCM argl)
-#define FUNC_NAME s_call_with_new_thread
-{
- SCM thread;
-
- /* Check arguments. */
- {
- register SCM args = argl;
- SCM thunk, handler;
- if (!SCM_CONSP (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_CONSP (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_NULLP (SCM_CDR (args)))
- SCM_WRONG_NUM_ARGS ();
- }
-
- /* Make new thread. */
- {
- coop_t *t;
- SCM root, old_winds;
-
- /* 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);
- /* Make thread. */
- thread = scm_cell (scm_tc16_thread, 0);
- SCM_DEFER_INTS;
- argl = scm_cons (thread, argl);
- /* Note that we couldn't pass a pointer to argl as data since the
- argl variable may not exist in memory when the thread starts. */
- t = coop_create (scheme_launch_thread, (void *) argl);
- t->data = SCM_ROOT_STATE (root);
- t->handle = thread;
- SCM_SET_CELL_WORD_1 (thread, (scm_t_bits) t);
- scm_thread_count++;
- all_threads = scm_cons (thread, all_threads);
- /* Note that the following statement also could cause coop_yield.*/
- SCM_ALLOW_INTS;
-
- /* We're now ready for the thread to begin. */
- coop_yield();
-
- /* Return to old dynamic context. */
- scm_dowinds (old_winds, - scm_ilength (old_winds));
- }
-
- return thread;
-}
-#undef FUNC_NAME
-
-
-/* This is the second thread spawning mechanism: threads from C */
-
-typedef struct c_launch_data {
- union {
- SCM thread;
- SCM rootcont;
- } u;
- scm_t_catch_body body;
- void *body_data;
- scm_t_catch_handler handler;
- void *handler_data;
-} c_launch_data;
-
-static SCM
-c_body_bootstrip (c_launch_data* data)
-{
- /* First save the new root continuation */
- data->u.rootcont = scm_root->rootcont;
- return (data->body) (data->body_data);
-}
-
-static SCM
-c_handler_bootstrip (c_launch_data* data, SCM tag, SCM throw_args)
-{
- scm_root->rootcont = data->u.rootcont;
- return (data->handler) (data->handler_data, tag, throw_args);
-}
-
-static void
-c_launch_thread (void *p)
-{
- register c_launch_data *data = (c_launch_data *) p;
- /* The thread object will be GC protected by being on this stack */
- SCM thread = data->u.thread;
- /* We must use the address of `thread', otherwise the compiler will
- optimize it away. This is OK since the longest SCM_STACKITEM
- also is a long. */
- scm_internal_cwdr ((scm_t_catch_body) c_body_bootstrip,
- data,
- (scm_t_catch_handler) c_handler_bootstrip,
- data,
- (SCM_STACKITEM *) &thread);
- scm_thread_count--;
- free ((char *) data);
-}
-
-SCM
-scm_spawn_thread (scm_t_catch_body body, void *body_data,
- scm_t_catch_handler handler, void *handler_data)
-{
- SCM thread;
- coop_t *t;
- SCM root, old_winds;
- c_launch_data *data = (c_launch_data *) scm_malloc (sizeof (*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);
- /* Make thread. */
- thread = scm_cell (scm_tc16_thread, 0);
- SCM_DEFER_INTS;
-
- data->u.thread = thread;
- data->body = body;
- data->body_data = body_data;
- data->handler = handler;
- data->handler_data = handler_data;
-
- t = coop_create (c_launch_thread, (void *) data);
- t->data = SCM_ROOT_STATE (root);
- t->handle = thread;
- SCM_SET_CELL_WORD_1 (thread, (scm_t_bits) t);
- scm_thread_count++;
- all_threads = scm_cons (thread, all_threads);
- /* Note that the following statement also could cause coop_yield.*/
- SCM_ALLOW_INTS;
-
- /* We're now ready for the thread to begin. */
- coop_yield();
-
- /* Return to old dynamic context. */
- scm_dowinds (old_winds, - scm_ilength (old_winds));
-
- return thread;
-}
-
-SCM
-scm_current_thread (void)
-{
- return coop_global_curr->handle;
-}
-
-SCM
-scm_all_threads (void)
-{
- return all_threads;
-}
-
-scm_root_state *
-scm_i_thread_root (SCM thread)
-{
- return (scm_root_state *)((coop_t *)SCM_THREAD_DATA (thread))->data;
-}
-
-SCM
-scm_join_thread (SCM thread)
-#define FUNC_NAME s_join_thread
-{
- coop_t *thread_data;
- SCM_VALIDATE_THREAD (1, thread);
- /* Dirk:FIXME:: SCM_THREAD_DATA is a handle for a thread. It may be that a
- * certain thread implementation uses a value of 0 as a valid thread handle.
- * With the following code, this thread would always be considered finished.
- */
- /* Dirk:FIXME:: With preemptive threading, a thread may finish immediately
- * after SCM_THREAD_DATA is read. Thus, it must be guaranteed that the
- * handle remains valid until the thread-object is garbage collected, or
- * a mutex has to be used for reading and modifying SCM_THREAD_DATA.
- */
- thread_data = SCM_THREAD_DATA (thread);
- if (thread_data)
- /* The thread is still alive */
- coop_join (thread_data);
- /* XXX - return real result. */
- return SCM_BOOL_T;
-}
-#undef FUNC_NAME
-
-int
-scm_c_thread_exited_p (SCM thread)
-#define FUNC_NAME s_scm_thread_exited_p
-{
- SCM_VALIDATE_THREAD (1, thread);
- return SCM_THREAD_DATA (thread) != NULL;
-}
-#undef FUNC_NAME
-
-SCM
-scm_yield (void)
-{
- /* Yield early */
- scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
- coop_yield();
-
- return SCM_BOOL_T;
-}
-
-SCM
-scm_single_thread_p (void)
-{
- return (coop_global_runq.tail == &coop_global_runq.t
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-SCM
-scm_make_mutex (void)
-{
- SCM m = scm_make_smob (scm_tc16_mutex);
- coop_mutex_init (SCM_MUTEX_DATA (m));
- return m;
-}
-
-SCM
-scm_lock_mutex (SCM m)
-{
- SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);
- coop_mutex_lock (SCM_MUTEX_DATA (m));
- return SCM_BOOL_T;
-}
-
-SCM
-scm_try_mutex (SCM m)
-{
- SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);
- return scm_from_bool (coop_mutex_trylock (SCM_MUTEX_DATA (m)));
-}
-
-SCM
-scm_unlock_mutex (SCM m)
-{
- SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_unlock_mutex);
- coop_mutex_unlock(SCM_MUTEX_DATA (m));
-
- /* Yield early */
- scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
- coop_yield();
-
- return SCM_BOOL_T;
-}
-
-SCM
-scm_make_condition_variable (void)
-{
- SCM c = scm_make_smob (scm_tc16_condvar);
- coop_condition_variable_init (SCM_CONDVAR_DATA (c));
- return c;
-}
-
-SCM
-scm_timed_wait_condition_variable (SCM c, SCM m, SCM t)
-#define FUNC_NAME s_wait_condition_variable
-{
- coop_c *cv;
- coop_m *mx;
- scm_t_timespec waittime;
-
- SCM_ASSERT (SCM_CONDVARP (c),
- c,
- SCM_ARG1,
- s_wait_condition_variable);
- SCM_ASSERT (SCM_MUTEXP (m),
- m,
- SCM_ARG2,
- s_wait_condition_variable);
-
- cv = SCM_CONDVAR_DATA (c);
- mx = SCM_MUTEX_DATA (m);
-
- 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;
- }
- return scm_from_bool(
- coop_condition_variable_timed_wait_mutex (cv, mx, &waittime));
- }
- else
- {
- coop_condition_variable_wait_mutex (cv, mx);
- return SCM_BOOL_T;
- }
-}
-#undef FUNC_NAME
-
-SCM
-scm_signal_condition_variable (SCM c)
-{
- SCM_ASSERT (SCM_CONDVARP (c),
- c,
- SCM_ARG1,
- s_signal_condition_variable);
- coop_condition_variable_signal (SCM_CONDVAR_DATA (c));
- return SCM_BOOL_T;
-}
-
-SCM
-scm_broadcast_condition_variable (SCM c)
-{
- SCM_ASSERT (SCM_CONDVARP (c),
- c,
- SCM_ARG1,
- s_broadcast_condition_variable);
- coop_condition_variable_broadcast (SCM_CONDVAR_DATA (c));
- return SCM_BOOL_T;
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
HCoop / bpt / guile.git / blobdiff