mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
495 lines
13 KiB
C
495 lines
13 KiB
C
/* Copyright (C) 1995, 1996 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), argl, SCM_WNA, s_call_with_new_thread);
|
||
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), argl, SCM_WNA, s_call_with_new_thread);
|
||
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)), argl, SCM_WNA, s_call_with_new_thread);
|
||
}
|
||
|
||
/* 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;
|
||
}
|