/* 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: */