-/* 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, 675 Mass Ave, Cambridge, MA 02139, 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.
- */
-\f
-
-/* A counter of the current number of threads */
-size_t scm_thread_count = 0;
-
-/* This is included rather than compiled seperately in order
- to simplify the configuration mechanism. */
-#include "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 struct gscm_type scm_thread_type;
-static struct gscm_type scm_mutex_type;
-static struct gscm_type scm_condition_variable_type;
-
-/* This mutex is used to synchronize thread creation */
-static coop_m scm_coop_create_mutex;
-
-/* Support structure for thread creation */
-struct scm_coop_create_info_type scm_coop_create_info;
-
-#ifdef __STDC__
-int
-gscm_threads_thread_equal (SCM t1, SCM t2)
-#else
-int
-gscm_threads_thread_equal (t1, t2)
- SCM t1, t2;
-#endif
-{
- return (*(coop_t **) gscm_unwrap_obj (&scm_thread_type, &t1) ==
- *(coop_t **) gscm_unwrap_obj (&scm_thread_type, &t2));
-}
-
-#ifdef __STDC__
-void
-gscm_threads_thread_die (SCM t)
-#else
-void
-gscm_threads_thread_die (t)
- SCM t;
-#endif
-{
- coop_t **thread = (coop_t **) gscm_unwrap_obj (&scm_thread_type, &t);
- free(*thread);
-}
-
-#ifdef __STDC__
-void
-gscm_threads_mutex_die (SCM m)
-#else
-void
-gscm_threads_scm_mutex_die (m)
- SCM m;
-#endif
-{
- /* He's dead, Jim */
-}
-
-#ifdef __STDC__
-void
-gscm_threads_condition_variable_die (SCM c)
-#else
-void
-gscm_threads_condition_variable_die (c)
- SCM c;
-#endif
-{
- /* He's dead, Jim */
-}
-
-#ifdef __STDC__
-void
-gscm_threads_init ()
-#else
-void
-gscm_threads_init ()
-#endif
-{
-}
-
-/* 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
-{
-}
-
-#ifdef __STDC__
-void
-gscm_threads_init_coop_threads ()
-#else
-void
-gscm_threads_init_coop_threads ()
-#endif
-{
- SCM *prots;
-
- coop_init();
-
- scm_thread_count = 1;
-
- prots = (SCM *)malloc (sizeof (SCM) * scm_num_thread_local_protects);
-
- coop_global_main.sto = &prots;
- coop_global_main.base = &prots;
- coop_global_curr = &coop_global_main;
- coop_all_qput (&coop_global_allq, coop_global_curr);
-
- coop_mutex_init(&scm_coop_create_mutex);
- coop_mutex_init(&scm_critical_section_mutex);
-
- coop_global_main.data = prots;
-
- /* Initialize the root thread specific data pointer. All new threads
- get a copy of this buffer.
- scm_root_prots = prots; */
-}
-
-#ifdef __STDC__
-void
-gscm_threads_mark_stacks ()
-#else
-void
-gscm_threads_mark_stacks ()
-#endif
-{
- coop_t *thread;
- int j;
- jmp_buf scm_save_regs_gc_mark;
-
- 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 */
-#ifdef STACK_GROWS_UP
- long stack_len = (STACKITEM *) (&thread) -
- (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 values from LENGTH and CHARS must remain
- * usable. This requirement is stricter than a liveness
- * requirement -- in particular, it constrains the implementation
- * of scm_resizuve.
- */
- FLUSH_REGISTER_WINDOWS;
- /* This assumes that all registers are saved into the jmp_buf */
- setjmp (scm_save_regs_gc_mark);
- scm_mark_locations ((STACKITEM *) scm_save_regs_gc_mark,
- ((sizet) sizeof scm_save_regs_gc_mark
- / sizeof (STACKITEM)), BOOL_T);
-
- scm_mark_locations (((size_t) thread->base,
- (sizet) stack_len, BOOL_T));
-#else
- long stack_len = (STACKITEM *) thread->base -
- (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 LENGTH and CHARS must remain
- * usable. This requirement is stricter than a liveness
- * requirement -- in particular, it constrains the implementation
- * of scm_resizuve.
- */
- FLUSH_REGISTER_WINDOWS;
- /* This assumes that all registers are saved into the jmp_buf */
- setjmp (scm_save_regs_gc_mark);
- scm_mark_locations ((STACKITEM *) scm_save_regs_gc_mark,
- ((sizet) sizeof scm_save_regs_gc_mark
- / sizeof (STACKITEM)), BOOL_T);
-
- scm_mark_locations ((STACKITEM *) &thread,
- stack_len, BOOL_T);
-#endif
- }
- else
- {
- /* Suspended thread */
-#ifdef STACK_GROWS_UP
- long stack_len = (STACKITEM *) (thread->sp) -
- (STACKITEM *) thread->base;
-
- scm_mark_locations (((size_t)thread->base,
- (sizet) stack_len, BOOL_T));
-#else
- long stack_len = (STACKITEM *) thread->base -
- (STACKITEM *) (thread->sp);
-
- /* Registers are already on the stack. No need to mark. */
-
- scm_mark_locations ((STACKITEM *) (size_t)thread->sp,
- stack_len, BOOL_T);
-#endif
- }
-
- /* Mark all the of this thread's thread-local protects */
- for (j = scm_num_thread_local_protects-1; j >= 0; j--)
- {
- scm_gc_mark (((SCM*)(thread->data))[j], BOOL_F);
- }
- }
-}
-
-#ifdef __STDC__
-void
-launch_thread (void *p)
-#else
-void
-launch_thread (p)
- void *p;
-#endif
-{
- SCM thunk = scm_coop_create_info.thunk;
- SCM error = scm_coop_create_info.error;
-
- /* dynwinds must be set to BOOL_F for each new thread
- (it is a thread-local variable) */
- dynwinds = BOOL_F;
-
- coop_mutex_unlock(&scm_coop_create_mutex);
-
- scm_with_dynamic_root (thunk, error);
-
- scm_thread_count--;
-}
-
-#ifdef __STDC__
-SCM
-gscm_threads_with_new_thread (SCM thunk, SCM error_thunk)
-#else
-SCM
-gscm_threads_with_new_thread (thunk, error_thunk)
- SCM thunk;
- SCM error_thunk;
-#endif
-{
- int rc;
- SCM t = gscm_alloc (&scm_thread_type, sizeof(coop_t *));
-
- coop_t **pt = (coop_t **) gscm_unwrap_obj (&scm_thread_type, &t);
-
- int status;
-
- /* Rather than allocate space to hold fn and arg, a mutex is used
- to serialize thread creation. */
- coop_mutex_lock(&scm_coop_create_mutex);
-
- /* this data is passed to the newly created thread */
- scm_coop_create_info.thunk = thunk;
- scm_coop_create_info.error = error_thunk;
-
- *pt = coop_create(launch_thread, &scm_coop_create_info);
- scm_thread_count++;
-
- {
- SCM * prots;
-
- prots = (SCM *)malloc (sizeof (SCM) * scm_num_thread_local_protects);
-
- (*pt)->data = prots;
-
- /* Copy root thread specific data over */
- memcpy(prots, (SCM*)coop_global_curr->data,
- sizeof (SCM) * scm_num_thread_local_protects);
-
- prots[SCM_THREAD_T] = t;
- prots[SCM_THREAD_THUNK] = thunk;
- prots[SCM_THREAD_ERROR] = error_thunk;
- }
-
- /* we're now ready for the thread to begin */
- coop_yield();
-
- return t;
-}
-
-#ifdef __STDC__
-SCM
-gscm_threads_join_thread (SCM t)
-#else
-SCM
-gscm_threads_join_thread (t)
- SCM t;
-#endif
-{
- coop_t **thread = (coop_t **) gscm_unwrap_obj (&scm_thread_type, &t);
-
- coop_join(*thread);
-
- return SCM_BOOL_T;
-}
-
-#ifdef __STDC__
-SCM
-gscm_threads_make_mutex ()
-#else
-SCM
-gscm_threads_make_mutex ()
-#endif
-{
- SCM t = gscm_alloc (&scm_mutex_type, sizeof(coop_m));
-
- coop_m *m = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &t);
-
- coop_mutex_init(m);
-
- return t;
-}
-
-#ifdef __STDC__
-SCM
-gscm_threads_lock_mutex (SCM m)
-#else
-SCM
-gscm_threads_lock_mutex (m)
- SCM m;
-#endif
-{
- coop_m *mutex = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &m);
-
- coop_mutex_lock(mutex);
-
- return SCM_BOOL_T;
-}
-
-#ifdef __STDC__
-SCM
-gscm_threads_unlock_mutex (SCM m)
-#else
-SCM
-gscm_threads_unlock_mutex (m)
- SCM m;
-#endif
-{
- coop_m *mutex = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &m);
-
- coop_mutex_unlock(mutex);
-
- /* Yield early */
- scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
- coop_yield();
-
- return SCM_BOOL_T;
-}
-
-#ifdef __STDC__
-SCM
-gscm_threads_make_condition_variable ()
-#else
-SCM
-gscm_threads_make_condition_variable ()
-#endif
-{
- SCM t = gscm_alloc (&scm_mutex_type, sizeof(coop_c));
-
- coop_c *c = (coop_c *) gscm_unwrap_obj (&scm_condition_variable_type, &t);
-
- coop_condition_variable_init(c);
-
- return t;
-}
-
-#ifdef __STDC__
-SCM
-gscm_threads_condition_variable_wait (SCM c, SCM m)
-#else
-SCM
-gscm_threads_condition_variable_wait (c, m)
- SCM c;
- SCM m;
-#endif
-{
- coop_c *cv = (coop_c *) gscm_unwrap_obj (&scm_condition_variable_type, &c);
- coop_m *mutex = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &m);
-
- coop_mutex_unlock(mutex);
- coop_condition_variable_wait(cv);
-
- return SCM_BOOL_T;
-}
-
-#ifdef __STDC__
-SCM
-gscm_threads_condition_variable_signal (SCM c)
-#else
-SCM
-gscm_threads_condition_variable_signal (c)
- SCM c;
-#endif
-{
- coop_c *cv = (coop_c *) gscm_unwrap_obj (&scm_condition_variable_type, &c);
-
- coop_condition_variable_signal(cv);
-
- return SCM_BOOL_T;
-}
-
-#ifdef __STDC__
-SCM
-gscm_threads_yield ()
-#else
-SCM
-gscm_threads_yield ()
-#endif
-{
- /* Yield early */
- scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
- coop_yield();
-
- return SCM_BOOL_T;
-}
HCoop / bpt / guile.git / blobdiff