diff options
Diffstat (limited to 'libguile/coop-threads.c')
| -rw-r--r-- | libguile/coop-threads.c | 549 |
1 files changed, 0 insertions, 549 deletions
diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index cd50b45aa..e69de29bb 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -1,549 +0,0 @@ -/* 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 - */ - - - - -#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: -*/ |