/* Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2, or (at your option) * any later version. * * This program 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 General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * Boston, MA 02111-1307 USA * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. * * The exception is that, if you link the GUILE library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of * linking the GUILE library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the * Free Software Foundation under the name GUILE. If you copy * code from other Free Software Foundation releases into a copy of * GUILE, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ typedef struct scm_pthread_info { queue q; /* the dequeue on which this structure exists */ /* reqired to be the first element */ pthread_t thread; /* the corresponding thread structure */ void *stack_top; /* the highest address in this thread's stack */ scm_root_state *root; /* root for this thread */ } scm_pthread_info; pthread_mutex_t scm_critical_section_mutex; pthread_t scm_critical_section_owner; static queue infos = { &infos, &infos }; /* the dequeue of info structures */ /* Key to thread specific data */ pthread_key_t info_key; #ifdef __STDC__ size_t scm_threads_free_thread (SCM t) #else size_t scm_threads_free_thread (t) SCM t; #endif { scm_must_free (SCM_THREAD_DATA (t)); return sizeof (pthread_t); } #ifdef __STDC__ size_t scm_threads_free_mutex (SCM m) #else size_t scm_threads_free_mutex (m) SCM m; #endif { pthread_mutex_destroy (SCM_MUTEX_DATA (m)); scm_must_free (SCM_MUTEX_DATA (m)); return sizeof (pthread_mutex_t); } #ifdef __STDC__ size_t scm_threads_free_condvar (SCM c) #else size_t scm_threads_free_condvar (c) SCM c; #endif { pthread_cond_destroy (SCM_CONDVAR_DATA (c)); scm_must_free (SCM_CONDVAR_DATA (c)); return sizeof (pthread_cond_t); } /* cleanup for info structure */ #ifdef __STDC__ static void scm_pthread_delete_info (void *ptr) #else static void scm_pthread_delete_info (ptr) void *ptr; #endif { scm_pthread_info *info = (scm_pthread_info *) ptr; info->q.blink->flink = info->q.flink; info->q.flink->blink = info->q.blink; scm_must_free ((char *) info); } #ifdef __STDC__ void scm_threads_init (SCM_STACKITEM *i) #else void scm_threads_init (i) SCM_STACKITEM *i; #endif { /* * each info structure is made thread-specific, so that the cleanup * mechanism can be used to reclaim the space in a timely fashion. */ pthread_key_create (&info_key, scm_pthread_delete_info); /* initialize various mutex variables */ pthread_mutex_init (&scm_critical_section_mutex, NULL); /* * create an info structure for the initial thread and push it onto * the info dequeue */ { scm_pthread_info *info; info = (scm_pthread_info *) scm_must_malloc (sizeof (scm_pthread_info), "threads_init"); infos.flink = infos.blink = &info->q; info->q.flink = info->q.blink = &infos; info->thread = pthread_initial; info->stack_top = (void *) i; pthread_setspecific(info_key, info); } /* The root state pointer gets initialized in init.c. */ } /* given some thread, find the corresponding info */ static scm_pthread_info *pthreads_find_info (pthread_t target) { queue *ptr = infos.flink; while (ptr != &infos) { scm_pthread_info *info = (scm_pthread_info *) ptr; if (info->thread == target) { return (info); } ptr = ptr->flink; } } #ifdef __STDC__ void scm_threads_mark_stacks () #else void scm_threads_mark_stacks () #endif { scm_pthread_info *info; pthread_t thread; int j; for (info = (scm_pthread_info *) infos.flink; info != (scm_pthread_info *) &infos; info = (scm_pthread_info *) info->q.flink) { thread = info->thread; if (thread == pthread_run) { /* Active thread */ /* stack_len is long rather than sizet in order to guarantee that &stack_len is long aligned */ #ifdef STACK_GROWS_UP long stack_len = ((SCM_STACKITEM *) (&thread) - (SCM_STACKITEM *) info->stack_top); /* 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 values from SCM_LENGTH and SCM_CHARS 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, ((scm_sizet) sizeof scm_save_regs_gc_mark / sizeof (SCM_STACKITEM))); scm_mark_locations (((size_t) info->stack_top, (sizet) stack_len)); #else long stack_len = ((SCM_STACKITEM *) info->stack_top - (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 values from SCM_LENGTH and SCM_CHARS 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, ((scm_sizet) sizeof scm_save_regs_gc_mark / sizeof (SCM_STACKITEM))); scm_mark_locations ((SCM_STACKITEM *) &thread, stack_len); #endif } else { /* Suspended thread */ #ifdef STACK_GROWS_UP long stack_len = ((SCM_STACKITEM *) (thread->THREAD_SP) - (SCM_STACKITEM *) info->stack_top); scm_mark_locations ((size_t)info->stack_top, (sizet) stack_len); #else long stack_len = ((SCM_STACKITEM *) info->stack_top - (SCM_STACKITEM *) (thread->THREAD_SP)); scm_mark_locations ((SCM_STACKITEM *) thread->machdep_data.machdep_state, ((scm_sizet) sizeof (*thread->machdep_data.machdep_state) / sizeof (SCM_STACKITEM))); scm_mark_locations ((SCM_STACKITEM *) (size_t) thread->THREAD_SP, stack_len); #endif } /* Mark this thread's root */ scm_gc_mark (((scm_root_state *) info->root) -> handle); } } #ifdef __STDC__ void * launch_thread (void *p) #else void * launch_thread (p) void *p; #endif { /* 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. */ SCM args = (SCM) p; pthread_attr_setcleanup (&pthread_self () -> attr, NULL, SCM_ROOT_STATE (SCM_CAR (args))); scm_call_with_dynamic_root (SCM_CADDR (args), SCM_CADDDR (args)); return NULL; } #ifdef __STDC__ SCM scm_call_with_new_thread (SCM argl) #else SCM scm_call_with_new_thread (argl) SCM argl; #endif { SCM thread; /* Check arguments. */ { register SCM args = argl; SCM thunk, handler; SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_call_with_new_thread), SCM_WNA, NULL); thunk = SCM_CAR (args); SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), thunk, SCM_ARG1, s_call_with_new_thread); args = SCM_CDR (args); SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_call_with_new_thread), SCM_WNA, NULL); handler = SCM_CAR (args); SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)), handler, SCM_ARG2, s_call_with_new_thread); SCM_ASSERT (SCM_NULLP (SCM_CDR (args)), scm_makfrom0str (s_call_with_new_thread), SCM_WNA, NULL); } /* Make new thread. */ { pthread_attr_t attr; pthread_t t; scm_pthread_info *info = (scm_pthread_info *) scm_must_malloc (sizeof (scm_pthread_info), "pthread_info"); 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. */ SCM_NEWCELL (thread); SCM_DEFER_INTS; SCM_SETCAR (thread, scm_tc16_thread); argl = scm_cons2 (root, thread, argl); /* thread mustn't start until we've built the info struct */ pthread_kernel_lock++; /* initialize and create the thread. */ pthread_attr_init (&attr); pthread_attr_setschedpolicy (&attr, SCHED_RR); pthread_create (&t, &attr, launch_thread, (void *) argl); pthread_attr_destroy (&attr); /* push the info onto the dequeue */ info->q.flink = infos.flink; info->q.blink = &infos; infos.flink->blink = &info->q; infos.flink = &info->q; /* pthread_create filled in the initial SP -- profitons-en ! */ info->stack_top = (void *) (t->THREAD_SP); info->thread = t; info->root = SCM_ROOT_STATE (root); SCM_SETCDR (thread, t); SCM_ALLOW_INTS; /* we're now ready for the thread to begin */ pthread_kernel_lock--; /* Return to old dynamic context. */ scm_dowinds (old_winds, - scm_ilength (old_winds)); } return thread; } #ifdef __STDC__ SCM scm_join_thread (SCM t) #else SCM scm_join_thread (t) SCM t; #endif { void *value; pthread_join (SCM_THREAD_DATA (t), &value); return SCM_BOOL_T; } #ifdef __STDC__ SCM scm_yield () #else SCM scm_yield () #endif { pthread_yield (); return SCM_BOOL_T; } #ifdef __STDC__ SCM scm_make_mutex () #else SCM scm_make_mutex () #endif { SCM m; pthread_mutex_t *data = (pthread_mutex_t *) scm_must_malloc (sizeof (pthread_mutex_t), "mutex"); SCM_NEWCELL (m); SCM_DEFER_INTS; SCM_SETCAR (m, scm_tc16_mutex); SCM_SETCDR (m, data); SCM_ALLOW_INTS; pthread_mutex_init (SCM_MUTEX_DATA (m), NULL); return m; } #ifdef __STDC__ SCM scm_lock_mutex (SCM m) #else SCM scm_lock_mutex (m) SCM m; #endif { SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex); pthread_mutex_lock (SCM_MUTEX_DATA (m)); return SCM_BOOL_T; } #ifdef __STDC__ SCM scm_unlock_mutex (SCM m) #else SCM scm_unlock_mutex (m) SCM m; #endif { SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_unlock_mutex); pthread_mutex_unlock (SCM_MUTEX_DATA (m)); return SCM_BOOL_T; } #ifdef __STDC__ SCM scm_make_condition_variable () #else SCM scm_make_condition_variable () #endif { SCM c; pthread_cond_t *data = (pthread_cond_t *) scm_must_malloc (sizeof (pthread_cond_t), "condvar"); SCM_NEWCELL (c); SCM_DEFER_INTS; SCM_SETCAR (c, scm_tc16_condvar); SCM_SETCDR (c, data); SCM_ALLOW_INTS; pthread_cond_init (SCM_CONDVAR_DATA (c), NULL); return c; } #ifdef __STDC__ SCM scm_wait_condition_variable (SCM c, SCM m) #else SCM scm_wait_condition_variable (c, m) SCM c; SCM m; #endif { SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c), c, SCM_ARG1, s_wait_condition_variable); SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG2, s_wait_condition_variable); pthread_cond_wait (SCM_CONDVAR_DATA (m), SCM_MUTEX_DATA (c)); return SCM_BOOL_T; } #ifdef __STDC__ SCM scm_signal_condition_variable (SCM c) #else SCM scm_signal_condition_variable (c) SCM c; #endif { SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c), c, SCM_ARG1, s_signal_condition_variable); pthread_cond_signal (SCM_CONDVAR_DATA (c)); return SCM_BOOL_T; }