-/* 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
-
-#include "coop-threads.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 "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;
-
-#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 (coop_t);
-}
-
-#ifdef __STDC__
-size_t
-scm_threads_free_mutex (SCM m)
-#else
-size_t
-scm_threads_free_mutex (m)
- SCM m;
-#endif
-{
- scm_must_free (SCM_MUTEX_DATA (m));
- return sizeof (coop_m);
-}
-
-#ifdef __STDC__
-size_t
-scm_threads_free_condvar (SCM c)
-#else
-size_t
-scm_threads_free_condvar (c)
- SCM c;
-#endif
-{
- scm_must_free (SCM_CONDVAR_DATA (c));
- return sizeof (coop_c);
-}
-
-#ifdef __STDC__
-void
-scm_threads_init (SCM_STACKITEM *i)
-#else
-void
-scm_threads_init (i)
- SCM_STACKITEM *i;
-#endif
-{
- coop_init();
-
- scm_thread_count = 1;
-
- coop_global_main.sto = i;
- 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 */
-}
-
-#ifdef __STDC__
-void
-scm_threads_mark_stacks ()
-#else
-void
-scm_threads_mark_stacks ()
-#endif
-{
- 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 */
-#ifdef 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 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) 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 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->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);
- }
-}
-
-#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;
- scm_call_with_dynamic_root (SCM_CADR (args), SCM_CADDR (args));
- scm_thread_count--;
-}
-
-#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. */
- {
- 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. */
- SCM_NEWCELL (thread);
- SCM_DEFER_INTS;
- SCM_SETCAR (thread, scm_tc16_thread);
- argl = scm_cons (thread, argl);
- t = coop_create (launch_thread, (void *) argl);
- t->data = SCM_ROOT_STATE (root);
- SCM_SETCDR (thread, t);
- scm_thread_count++;
- /* 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;
-}
-
-#ifdef __STDC__
-SCM
-scm_join_thread (SCM t)
-#else
-SCM
-scm_join_thread (t)
- SCM t;
-#endif
-{
- SCM_ASSERT (SCM_NIMP (t) && SCM_THREADP (t), t, SCM_ARG1, s_join_thread);
- coop_join (SCM_THREAD_DATA (t));
- return SCM_BOOL_T;
-}
-
-#ifdef __STDC__
-SCM
-scm_yield ()
-#else
-SCM
-scm_yield ()
-#endif
-{
- /* Yield early */
- scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
- coop_yield();
-
- return SCM_BOOL_T;
-}
-
-#ifdef __STDC__
-SCM
-scm_single_thread_p ()
-#else
-SCM
-scm_single_thread_p ()
-#endif
-{
- return (coop_global_runq.tail == &coop_global_runq.t
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-#ifdef __STDC__
-SCM
-scm_make_mutex ()
-#else
-SCM
-scm_make_mutex ()
-#endif
-{
- SCM m;
- coop_m *data = (coop_m *) scm_must_malloc (sizeof (coop_m), "mutex");
- SCM_NEWCELL (m);
- SCM_DEFER_INTS;
- SCM_SETCAR (m, scm_tc16_mutex);
- SCM_SETCDR (m, data);
- SCM_ALLOW_INTS;
- coop_mutex_init (data);
- 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);
- coop_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);
- coop_mutex_unlock(SCM_MUTEX_DATA (m));
-
- /* Yield early */
- scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
- coop_yield();
-
- return SCM_BOOL_T;
-}
-
-#ifdef __STDC__
-SCM
-scm_make_condition_variable ()
-#else
-SCM
-scm_make_condition_variable ()
-#endif
-{
- SCM c;
- coop_c *data = (coop_c *) scm_must_malloc (sizeof (coop_c), "condvar");
- SCM_NEWCELL (c);
- SCM_DEFER_INTS;
- SCM_SETCAR (c, scm_tc16_condvar);
- SCM_SETCDR (c, data);
- SCM_ALLOW_INTS;
- coop_condition_variable_init (SCM_CONDVAR_DATA (c));
- 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);
- coop_mutex_unlock (SCM_MUTEX_DATA (m));
- coop_condition_variable_wait (SCM_CONDVAR_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);
- coop_condition_variable_signal (SCM_CONDVAR_DATA (c));
- return SCM_BOOL_T;
-}
HCoop / bpt / guile.git / blobdiff