-@c -*-texinfo-*-
-@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
-@c Free Software Foundation, Inc.
-@c See the file guile.texi for copying conditions.
-
-
-@node Initialization
-@section Initializing Guile
-
-@deftypefn {C Function} void scm_boot_guile (int @var{argc}, char **@var{argv}, void (*@var{main_func}) (void *@var{data}, int @var{argc}, char **@var{argv}), void *@var{data})
-Initialize the Guile Scheme interpreter. Then call @var{main_func},
-passing it @var{data}, @var{argc}, and @var{argv} as indicated. The
-function @var{main_func} should do all the work of the program
-(initializing other packages, defining application-specific functions,
-reading user input, and so on) before returning. When @var{main_func}
-returns, @code{scm_boot_guile} calls @code{exit (0)};
-@code{scm_boot_guile} never returns. If you want some other exit
-value, have @var{main_func} call @code{exit} itself.
-
-@code{scm_boot_guile} arranges for the Scheme @code{command-line}
-function to return the strings given by @var{argc} and @var{argv}. If
-@var{main_func} modifies @var{argc} or @var{argv}, it should call
-@code{scm_set_program_arguments} with the final list, so Scheme code
-will know which arguments have been processed.
-
-Why must the caller do all the real work from @var{main_func}? Guile's
-garbage collector scans the stack to find all local variables that
-reference Scheme objects. To do this, it needs to know the bounds of
-the stack that might contain such references. Because there is no
-portable way in C to find the base of the stack, @code{scm_boot_guile}
-assumes that all references are above its own stack frame. If you try
-to manipulate Scheme objects after this function returns, it's the luck
-of the draw whether Guile's storage manager will be able to find the
-objects you allocate. So, @code{scm_boot_guile} function exits, rather
-than returning, to discourage you from making that mistake.
-
-See @code{scm_init_guile}, below, for a function that can find the real
-base of the stack, but not in a portable way.
-@end deftypefn
-
-@deftypefn {C Function} void scm_init_guile ()
-Initialize the Guile Scheme interpreter.
-
-In contrast to @code{scm_boot_guile}, this function knows how to find
-the true base of the stack and thus does not need to usurp the control
-flow of your program. However, since finding the stack base can not be
-done portably, this function might not be available in all installations
-of Guile. If you can, you should use @code{scm_boot_guile} instead.
-
-Note that @code{scm_init_guile} does not inform Guile about the command
-line arguments that should be returned by the Scheme function
-@code{command-line}. You can use @code{scm_set_program_arguments} to do
-this.
-@end deftypefn
-
-@deftypefn {C Function} void scm_shell (int @var{argc}, char **@var{argv})
-Process command-line arguments in the manner of the @code{guile}
-executable. This includes loading the normal Guile initialization
-files, interacting with the user or running any scripts or expressions
-specified by @code{-s} or @code{-e} options, and then exiting.
-@xref{Invoking Guile}, for more details.
-
-Since this function does not return, you must do all
-application-specific initialization before calling this function.
-@end deftypefn
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+
+@node Initialization
+@section Initializing Guile
+
+Each thread that wants to use function from the Guile API needs to put
+itself into guile mode with either @code{scm_with_guile} or
+@code{scm_init_guile}. The global state of Guile is initialized
+automatically when the first thread enters guile mode.
+
+When a thread wants to block outside of a Guile API function, it should
+leave guile mode temporarily with either @code{scm_without_guile} or
+@code{scm_leave_guile}, @xref{Threads}.
+
+Threads that are created by @code{call-with-new-thread} or
+@code{scm_spawn_thread} start out in guile mode so you don't need to
+initialize them.
+
+@deftypefn {C Function} void *scm_with_guile (void *(*func)(void *), void *data)
+Call @var{func}, passing it @var{data} and return what @var{func}
+returns. While @var{func} is running, the current thread is in guile
+mode and can thus use the Guile API.
+
+When @code{scm_with_guile} is called from guile mode, the thread remains
+in guile mode when @code{scm_with_guile} returns.
+
+Otherwise, it puts the current thread into guile mode and, if needed,
+gives it a Scheme representation that is contained in the list returned
+by @code{all-threads}, for example. This Scheme representation is not
+removed when @code{scm_with_guile} returns so that a given thread is
+always represented by the same Scheme value during its lifetime, if at
+all.
+
+When this is the first thread that enters guile mode, the global state
+of Guile is initialized before calling @code{func}.
+
+When a throw happens while @var{func} runs (such as a signalled error)
+that is not caught, a short message is printed to the current error port
+and @code{scm_with_guile} returns @code{NULL}. When a continuation is
+invoked that would make the control flow cross this call to
+@code{scm_with_guile}, an error will be signalled at the point of
+continuation invokation. Thus, @code{scm_with_guile} guaranteed to
+return exactly once.
+
+When @code{scm_with_guile} returns, the thread is no longer in guile
+mode (except when @code{scm_with_guile} was called from guile mode, see
+above). Thus, only @code{func} can store @code{SCM} variables on the
+stack and be sure that they are protected from the garbage collector.
+See @code{scm_init_guile} for another approach at initializing Guile
+that does not have this restriction.
+
+It is OK to call @code{scm_with_guile} while a thread has temporarily
+left guile mode via @code{scm_without_guile} or @code{scm_leave_guile}.
+It will then simply temporarily enter guile mode again.
+@end deftypefn
+
+@deftypefn {C Function} void scm_init_guile ()
+Arrange things so as if all of the code of the current thread would be
+executed from within a call to @code{scm_with_guile}. That is, all
+functions called by the current thread can assume that @code{SCM} values
+on their stack frames are protected from the garbage collector (except
+when the thread has explicitely left guile mode, of course).
+
+When @code{scm_init_guile} is called from a thread that already has been
+in guile mode once, nothing happens. This behavior matters when you
+call @code{scm_init_guile} while the thread has only temporarily left
+guile mode: in that case the thread will not be in guile mode after
+@code{scm_init_guile} returns. Thus, you should not use
+@code{scm_init_guile} in such a scenario.
+
+When a uncaught throw happens in a thread that has been put into guile
+mode via @code{scm_init_guile}, a short message is printed to the
+current error port and the thread is exited via @code{scm_pthread_exit
+(NULL)}. No restrictions are placed on continuations.
+
+The function @code{scm_init_guile} might not be available on all
+platforms since it requires some stack-bounds-finding magic that might
+not have been to all platforms that Guile runs on. Thus, if you can, it
+is better to use @code{scm_with_guile} or its variation
+@code{scm_boot_guile} instead of this function.
+@end deftypefn
+
+@deftypefn {C Function} void scm_boot_guile (int @var{argc}, char **@var{argv}, void (*@var{main_func}) (void *@var{data}, int @var{argc}, char **@var{argv}), void *@var{data})
+Enter guile mode as with @code{scm_with_guile} and call @var{main_func},
+passing it @var{data}, @var{argc}, and @var{argv} as indicated. When
+@var{main_func} returns, @code{scm_boot_guile} calls @code{exit (0)};
+@code{scm_boot_guile} never returns. If you want some other exit value,
+have @var{main_func} call @code{exit} itself. If you don't want to exit
+at all, use @code{scm_with_guile} instead of @code{scm_boot_guile}.
+
+The function @code{scm_boot_guile} arranges for the Scheme
+@code{command-line} function to return the strings given by @var{argc}
+and @var{argv}. If @var{main_func} modifies @var{argc} or @var{argv},
+it should call @code{scm_set_program_arguments} with the final list, so
+Scheme code will know which arguments have been processed.
+@end deftypefn
+
+@deftypefn {C Function} void scm_shell (int @var{argc}, char **@var{argv})
+Process command-line arguments in the manner of the @code{guile}
+executable. This includes loading the normal Guile initialization
+files, interacting with the user or running any scripts or expressions
+specified by @code{-s} or @code{-e} options, and then exiting.
+@xref{Invoking Guile}, for more details.
+
+Since this function does not return, you must do all
+application-specific initialization before calling this function.
+@end deftypefn
In addition to the C versions of @code{call-with-blocked-asyncs} and
@code{call-with-unblocked-asyncs}, C code can use
-@code{scm_with_blocked_asyncs} and @code{scm_with_unblocked_asyncs}
+@code{scm_frame_block_asyncs} and @code{scm_frame_unblock_asyncs}
inside a @dfn{frame} (@pxref{Frames}) to block or unblock system asyncs
temporarily.
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node General Libguile Concepts
@section General concepts for using libguile
-When you want to embed the Guile Scheme interpreter into your program,
-you need to link it against the @file{libguile} library (@pxref{Linking
-Programs With Guile}). Once you have done this, your C code has access
-to a number of data types and functions that can be used to invoke the
-interpreter, or make new functions that you have written in C available
-to be called from Scheme code, among other things.
+When you want to embed the Guile Scheme interpreter into your program or
+library, you need to link it against the @file{libguile} library
+(@pxref{Linking Programs With Guile}). Once you have done this, your C
+code has access to a number of data types and functions that can be used
+to invoke the interpreter, or make new functions that you have written
+in C available to be called from Scheme code, among other things.
Scheme is different from C in a number of significant ways, and Guile
tries to make the advantages of Scheme available to C as well. Thus, in
to use the rest of libguile. Also, the more general control flow of
Scheme caused by continuations needs to be dealt with.
+Running asynchronous signal handlers and multi-threading is known to C
+code already, but there are of course a few additional rules when using
+them together with libguile.
+
@menu
* Dynamic Types:: Dynamic Types.
* Garbage Collection:: Garbage Collection.
* Control Flow:: Control Flow.
+* Asynchronous Signals:: Asynchronous Signals
+* Multi-Threading:: Multi-Threading
@end menu
@node Dynamic Types
prefer to use the @dfn{frames} concept that is more natural for C code,
(@pxref{Frames}).
+@node Asynchronous Signals
+@subsection Asynchronous Signals
+
+You can not call libguile functions from handlers for POSIX signals, but
+you can register Scheme handlers for POSIX signals such as
+@code{SIGINT}. These handlers do not run during the actual signal
+delivery. Instead, they are run when the program (more precisely, the
+thread that the handler has been registered for) reaches the next
+@emph{safe point}.
+
+The libguile functions themselves have many such safe points.
+Consequently, you must be prepared for arbitrary actions anytime you
+call a libguile function. For example, even @code{scm_cons} can contain
+a safe point and when a signal handler is pending for your thread,
+calling @code{scm_cons} will run this handler and anything might happen,
+including a non-local exit although @code{scm_cons} would not ordinarily
+do such a thing on its own.
+
+If you do not want to allow the running of asynchronous signal handlers,
+you can block them temporarily with @code{scm_frame_block_asyncs}, for
+example. See @xref{System asyncs}.
+
+Since signal handling in Guile relies on safe points, you need to make
+sure that your functions do offer enough of them. Normally, calling
+libguile functions in the normal course of action is all that is needed.
+But when a thread might spent a long time in a code section that calls
+no libguile function, it is good to include explicit safe points. This
+can allow the user to interrupt your code with @key{C-c}, for example.
+
+You can do this with the macro @code{SCM_TICK}. This macro is
+syntactically a statement. That is, you could use it like this:
+
+@example
+while (1)
+ @{
+ SCM_TICK;
+ do_some_work ();
+ @}
+@end example
+
+Frequent execution of a safe point is even more important in multi
+threaded programs, @xref{Multi-Threading}.
+
+@node Multi-Threading
+@subsection Multi-Threading
+
+Guile can be used in multi-threaded programs just as well as in
+single-threaded ones.
+
+Each thread that wants to use functions from libguile must put itself
+into @emph{guile mode} and must then follow a few rules. If it doesn't
+want to honor these rules in certain situations, a thread can
+temporarily leave guile mode (but can no longer use libguile functions
+during that time, of course).
+
+Threads enter guile mode by calling @code{scm_with_guile},
+@code{scm_boot_guile}, or @code{scm_init_guile}. As explained in the
+reference documentation for these functions, Guile will then learn about
+the stack bounds of the thread and can protect the @code{SCM} values
+that are stored in local variables. When a thread puts itself into
+guile mode for the first time, it gets a Scheme representation and is
+listed by @code{all-threads}, for example.
+
+While in guile mode, a thread promises to reach a safe point reasonably
+frequently (@pxref{Asynchronous Signals}). In addition to running
+signal handlers, these points are also potential rendezvous points of
+all guile mode threads where Guile can orchestrate global things like
+garbage collection. Consequently, when a thread in guile mode blocks
+and does no longer frequent safe points, it might cause all other guile
+mode threads to block as well. To prevent this from happening, a guile
+mode thread should either only block in libguile functions (who know how
+to do it right), or should temporarily leave guile mode with
+@code{scm_without_guile} or
+@code{scm_leave_guile}/@code{scm_enter_guile}.
+
+For some common blocking operations, Guile provides convenience
+functions. For example, if you want to lock a pthread mutex while in
+guile mode, you might want to use @code{scm_pthread_mutex_lock} which is
+just like @code{pthread_mutex_lock} except that it leaves guile mode
+while blocking.
+
+
+All libguile functions are (intended to be) robust in the face of
+multiple threads using them concurrently. This means that there is no
+risk of the internal data structures of libguile becoming corrupted in
+such a way that the process crashes.
+
+A program might still produce non-sensical results, though. Taking
+hashtables as an example, Guile guarantees that you can use them from
+multiple threads concurrently and a hashtable will always remain a valid
+hashtable and Guile will not crash when you access it. It does not
+guarantee, however, that inserting into it concurrently from two threads
+will give useful results: only one insertion might actually happen, none
+might happen, or the table might in general be modified in a totally
+arbitrary manner. (It will still be a valid hashtable, but not the one
+that you might have expected.) Guile might also signal an error when it
+detects a harmful race condition.
+
+Thus, you need to put in additional synchronizations when multiple
+threads want to use a single hashtable, or any other mutable Scheme
+object.
+
+When writing C code for use with libguile, you should try to make it
+robust as well. An example that converts a list into a vector will help
+to illustrate. Here is a correct version:
+
+@example
+SCM
+my_list_to_vector (SCM list)
+@{
+ SCM vector = scm_make_vector (scm_length (list), SCM_UNDEFINED);
+ size_t len, i;
+
+ len = SCM_SIMPLE_VECTOR_LENGTH (vector);
+ i = 0;
+ while (i < len && scm_is_pair (list))
+ @{
+ SCM_SIMPLE_VECTOR_SET (vector, i, SCM_CAR (list));
+ list = SCM_CDR (list);
+ i++;
+ @}
+
+ return vector;
+@}
+@end example
+
+The first thing to note is that storing into a @code{SCM} location
+concurrently from multiple threads is guaranteed to be robust: you don't
+know which value wins but it will in any case be a valid @code{SCM}
+value.
+
+But there is no guarantee that the list referenced by @var{list} is not
+modified in another thread while the loop iterates over it. Thus, while
+copying its elements into the vector, the list might get longer or
+shorter. For this reason, the loop must check both that it doesn't
+overrun the vector (@code{SCM_SIMPLE_VECTOR_SET} does no range-checking)
+and that it doesn't overrung the list (@code{SCM_CAR} and @code{SCM_CDR}
+likewise do no type checking).
+
+It is safe to use @code{SCM_CAR} and @code{SCM_CDR} on the local
+variable @var{list} once it is known that the variable contains a pair.
+The contents of the pair might change spontaneously, but it will always
+stay a valid pair (and a local variable will of course not spontaneously
+point to a different Scheme object).
+
+Likewise, a simple vector such as the one returned by
+@code{scm_make_vector} is guaranteed to always stay the same length so
+that it is safe to only use SCM_SIMPLE_VECTOR_LENGTH once and store the
+result. (In the example, @var{vector} is safe anyway since it is a
+fresh object that no other thread can possibly know about until it is
+returned from @code{my_list_to_vector}.)
+
+Of course the behavior of @code{my_list_to_vector} is suboptimal when
+@var{list} does indeed gets asynchronously lengthened or shortened in
+another thread. But it is robust: it will always return a valid vector.
+That vector might be shorter than expected, or its last elements might
+be unspecified, but it is a valid vector and if a program wants to rule
+out these cases, it must avoid modifying the list asynchronously.
+
+Here is another version that is also correct:
+
+@example
+SCM
+my_pedantic_list_to_vector (SCM list)
+@{
+ SCM vector = scm_make_vector (scm_length (list), SCM_UNDEFINED);
+ size_t len, i;
+
+ len = SCM_SIMPLE_VECTOR_LENGTH (vector);
+ i = 0;
+ while (i < len)
+ @{
+ SCM_SIMPLE_VECTOR_SET (vector, i, scm_car (list));
+ list = scm_cdr (list);
+ i++;
+ @}
+
+ return vector;
+@}
+@end example
+
+This version uses the type-checking and thread-robust functions
+@code{scm_car} and @code{scm_cdr} instead of the faster, but less robust
+macros @code{SCM_CAR} and @code{SCM_CDR}. When the list is shortened
+(that is, when @var{list} holds a non-pair), @code{scm_car} will throw
+an error. This might be preferable to just returning a half-initialized
+vector.
+
+The API for accessing vectors and arrays of various kinds from C takes a
+slightly different approach to thread-robustness. In order to get at
+the raw memory that stores the elements of an array, you need to
+@emph{reserve} that array as long as you need the raw memory. During
+the time an array is reserved, its elements can still spontaneously
+change their values, but the memory itself and other things like the
+size of the array are guaranteed to stay fixed. Any operation that
+would change these parameters of an array that is currently reserved
+will signal an error. In order to avoid these errors, a program should
+of course put suitable synchronization mechanisms in place. As you can
+see, Guile itself is again only concerned about robustness, not about
+correctness: without proper synchronization, your program will likely
+not be correct, but the worst consequence is an error message.
(private or global, with unwind where necessary), and remove the
remaining DEFER/ALLOWs. */
-#define SCM_DEFER_INTS scm_rec_mutex_lock (&scm_i_defer_mutex);
+#define SCM_DEFER_INTS do { } while (0);
-#define SCM_ALLOW_INTS scm_rec_mutex_unlock (&scm_i_defer_mutex);
+#define SCM_ALLOW_INTS do { } while (0);
#define SCM_REDEFER_INTS SCM_DEFER_INTS
{
SCM ret;
scm_frame_begin (0);
- scm_frame_unwind_handler ((void(*)(void*)) scm_mutex_unlock,
- &scm_i_misc_mutex,
- SCM_F_WIND_EXPLICITLY);
- scm_mutex_lock (&scm_i_misc_mutex);
+ scm_frame_pthread_mutex_lock (&scm_i_misc_mutex);
ret = scm_from_locale_string (SCM_I_STRERROR (scm_to_int (err)));
* which are treated differently with respect to DEVAL. The heads of these
* sections are marked with the string "SECTION:". */
+#define _GNU_SOURCE
+
/* SECTION: This code is compiled once.
*/
#include "libguile/eval.h"
+#include <pthread.h>
+
\f
static SCM unmemoize_exprs (SCM expr, SCM env);
? SCM_CAR (x) \
: *scm_lookupcar ((x), (env), 1)))))
-SCM_REC_MUTEX (source_mutex);
+pthread_mutex_t source_mutex = PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP;
/* Lookup a given local variable in an environment. The local variable is
{
if (SCM_ISYMP (SCM_CAR (code)))
{
- scm_rec_mutex_lock (&source_mutex);
+ scm_pthread_mutex_lock (&source_mutex);
/* check for race condition */
if (SCM_ISYMP (SCM_CAR (code)))
m_expand_body (code, env);
- scm_rec_mutex_unlock (&source_mutex);
+ pthread_mutex_unlock (&source_mutex);
goto again;
}
}
{
if (SCM_ISYMP (form))
{
- scm_rec_mutex_lock (&source_mutex);
+ scm_pthread_mutex_lock (&source_mutex);
/* check for race condition */
if (SCM_ISYMP (SCM_CAR (x)))
m_expand_body (x, env);
- scm_rec_mutex_unlock (&source_mutex);
+ pthread_mutex_unlock (&source_mutex);
goto nontoplevel_begin;
}
else
{
if (SCM_ISYMP (SCM_CAR (proc)))
{
- scm_rec_mutex_lock (&source_mutex);
+ scm_pthread_mutex_lock (&source_mutex);
/* check for race condition */
if (SCM_ISYMP (SCM_CAR (proc)))
m_expand_body (proc, args);
- scm_rec_mutex_unlock (&source_mutex);
+ pthread_mutex_unlock (&source_mutex);
goto again;
}
else
{
SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
SCM_UNPACK (code),
- scm_make_rec_mutex ());
+ scm_make_recursive_mutex ());
+}
+
+static SCM
+promise_mark (SCM promise)
+{
+ scm_gc_mark (SCM_PROMISE_MUTEX (promise));
+ return SCM_PROMISE_DATA (promise);
}
static size_t
promise_free (SCM promise)
{
- scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise));
return 0;
}
#define FUNC_NAME s_scm_force
{
SCM_VALIDATE_SMOB (1, promise, promise);
- scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise));
+ scm_lock_mutex (SCM_PROMISE_MUTEX (promise));
if (!SCM_PROMISE_COMPUTED_P (promise))
{
SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
SCM_SET_PROMISE_COMPUTED (promise);
}
}
- scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise));
+ scm_unlock_mutex (SCM_PROMISE_MUTEX (promise));
return SCM_PROMISE_DATA (promise);
}
#undef FUNC_NAME
SCM_N_EVAL_OPTIONS);
scm_tc16_promise = scm_make_smob_type ("promise", 0);
- scm_set_smob_mark (scm_tc16_promise, scm_markcdr);
+ scm_set_smob_mark (scm_tc16_promise, promise_mark);
scm_set_smob_free (scm_tc16_promise, promise_free);
scm_set_smob_print (scm_tc16_promise, promise_print);
(SCM_F_PROMISE_COMPUTED & SCM_SMOB_FLAGS (promise))
#define SCM_SET_PROMISE_COMPUTED(promise) \
SCM_SET_SMOB_FLAGS ((promise), SCM_F_PROMISE_COMPUTED)
-#define SCM_PROMISE_MUTEX(promise) \
- ((scm_t_rec_mutex *) SCM_SMOB_DATA_2 (promise))
+#define SCM_PROMISE_MUTEX SCM_SMOB_OBJECT_2
#define SCM_PROMISE_DATA SCM_SMOB_OBJECT
#define SCM_SET_PROMISE_DATA SCM_SET_SMOB_OBJECT
{
long i;
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_pthread_mutex_lock (&scm_i_port_table_mutex);
for (i = 0; i < scm_i_port_table_size; i++)
{
}
}
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ pthread_mutex_unlock (&scm_i_port_table_mutex);
}
SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
}
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_pthread_mutex_lock (&scm_i_port_table_mutex);
port = scm_new_port_table_entry (scm_tc16_fport);
SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
scm_fport_buffer_add (port, -1, -1);
}
SCM_SET_FILENAME (port, name);
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ pthread_mutex_unlock (&scm_i_port_table_mutex);
return port;
}
#undef FUNC_NAME
list = SCM_FUTURE_NEXT (list); \
} while (0)
-SCM_MUTEX (future_admin_mutex);
+pthread_mutex_t future_admin_mutex = PTHREAD_MUTEX_INITIALIZER;
static SCM futures = SCM_EOL;
static SCM young = SCM_EOL;
static void
cleanup (scm_t_future *future)
{
- scm_mutex_destroy (&future->mutex);
- scm_cond_destroy (&future->cond);
+ pthread_mutex_destroy (&future->mutex);
+ pthread_cond_destroy (&future->cond);
scm_gc_free (future, sizeof (*future), s_future);
#ifdef SCM_FUTURES_DEBUG
++n_dead;
static SCM
future_loop (scm_t_future *future)
{
- scm_mutex_lock (&future->mutex);
+ scm_pthread_mutex_lock (&future->mutex);
do {
if (future->status == SCM_FUTURE_SIGNAL_ME)
- scm_cond_broadcast (&future->cond);
+ pthread_cond_broadcast (&future->cond);
future->status = SCM_FUTURE_COMPUTING;
future->data = (SCM_CLOSUREP (future->data)
? scm_i_call_closure_0 (future->data)
: scm_call_0 (future->data));
- scm_cond_wait (&future->cond, &future->mutex);
+ scm_pthread_cond_wait (&future->cond, &future->mutex);
} while (!future->die_p);
future->status = SCM_FUTURE_DEAD;
- scm_mutex_unlock (&future->mutex);
+ pthread_mutex_unlock (&future->mutex);
return SCM_UNSPECIFIED;
}
future_handler (scm_t_future *future, SCM key, SCM args)
{
future->status = SCM_FUTURE_DEAD;
- scm_mutex_unlock (&future->mutex);
+ pthread_mutex_unlock (&future->mutex);
return scm_apply_1 (*scm_loc_sys_thread_handler, key, args);
}
scm_t_future *f = scm_gc_malloc (sizeof (*f), s_future);
SCM future;
f->data = SCM_BOOL_F;
- scm_mutex_init (&f->mutex, &scm_i_plugin_mutex);
- scm_cond_init (&f->cond, 0);
+ pthread_mutex_init (&f->mutex, NULL);
+ pthread_cond_init (&f->cond, NULL);
f->die_p = 0;
f->status = SCM_FUTURE_TASK_ASSIGNED;
- scm_mutex_lock (&future_admin_mutex);
+ scm_pthread_mutex_lock (&future_admin_mutex);
SCM_NEWSMOB2 (future, scm_tc16_future, futures, f);
SCM_SET_FUTURE_DATA (future, thunk);
futures = future;
- scm_mutex_unlock (&future_admin_mutex);
+ pthread_mutex_unlock (&future_admin_mutex);
scm_spawn_thread ((scm_t_catch_body) future_loop,
SCM_FUTURE (future),
(scm_t_catch_handler) future_handler,
scm_i_make_future (SCM thunk)
{
SCM future;
- scm_mutex_lock (&future_admin_mutex);
+ scm_pthread_mutex_lock (&future_admin_mutex);
while (1)
{
if (!scm_is_null (old))
UNLINK (young, future);
else
{
- scm_mutex_unlock (&future_admin_mutex);
+ pthread_mutex_unlock (&future_admin_mutex);
return alloc_future (thunk);
}
- if (scm_mutex_trylock (SCM_FUTURE_MUTEX (future)))
+ if (pthread_mutex_trylock (SCM_FUTURE_MUTEX (future)))
kill_future (future);
else if (!SCM_FUTURE_ALIVE_P (future))
{
- scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
cleanup (SCM_FUTURE (future));
}
else
break;
}
LINK (futures, future);
- scm_mutex_unlock (&future_admin_mutex);
+ pthread_mutex_unlock (&future_admin_mutex);
SCM_SET_FUTURE_DATA (future, thunk);
SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_TASK_ASSIGNED);
- scm_cond_signal (SCM_FUTURE_COND (future));
- scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ pthread_cond_signal (SCM_FUTURE_COND (future));
+ pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
return future;
}
{
SCM res;
SCM_VALIDATE_FUTURE (1, future);
- scm_mutex_lock (SCM_FUTURE_MUTEX (future));
+ scm_pthread_mutex_lock (SCM_FUTURE_MUTEX (future));
if (SCM_FUTURE_STATUS (future) != SCM_FUTURE_COMPUTING)
{
SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_SIGNAL_ME);
- scm_cond_wait (SCM_FUTURE_COND (future), SCM_FUTURE_MUTEX (future));
+ scm_pthread_cond_wait (SCM_FUTURE_COND (future),
+ SCM_FUTURE_MUTEX (future));
}
if (!SCM_FUTURE_ALIVE_P (future))
{
- scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
SCM_MISC_ERROR ("requesting result from failed future ~A",
scm_list_1 (future));
}
res = SCM_FUTURE_DATA (future);
- scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
return res;
}
#undef FUNC_NAME
SCM future;
UNLINK (victims, future);
kill_future (future);
- scm_cond_signal (SCM_FUTURE_COND (future));
+ pthread_cond_signal (SCM_FUTURE_COND (future));
}
}
SCM next = undead, *nextloc = &undead;
while (!scm_is_null (next))
{
- if (scm_mutex_trylock (SCM_FUTURE_MUTEX (next)))
+ if (pthread_mutex_trylock (SCM_FUTURE_MUTEX (next)))
goto next;
else if (SCM_FUTURE_ALIVE_P (next))
{
- scm_cond_signal (SCM_FUTURE_COND (next));
- scm_mutex_unlock (SCM_FUTURE_MUTEX (next));
+ pthread_cond_signal (SCM_FUTURE_COND (next));
+ pthread_mutex_unlock (SCM_FUTURE_MUTEX (next));
next:
SCM_SET_GC_MARK (next);
nextloc = SCM_FUTURE_NEXTLOC (next);
{
SCM future;
UNLINK (next, future);
- scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
cleanup (SCM_FUTURE (future));
*nextloc = next;
}
return 0;
}
+scm_t_bits scm_tc16_future;
+
void
scm_init_futures ()
{
typedef struct scm_t_future {
SCM data;
- scm_t_mutex mutex;
- scm_t_cond cond;
+ pthread_mutex_t mutex;
+ pthread_cond_t cond;
int status;
int die_p;
} scm_t_future;
int init_heap_size_2
= scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", SCM_DEFAULT_INIT_HEAP_SIZE_2);
- /* These are the thread-local freelists. */
- scm_key_create (&scm_i_freelist, free);
- scm_key_create (&scm_i_freelist2, free);
- SCM_FREELIST_CREATE (scm_i_freelist);
- SCM_FREELIST_CREATE (scm_i_freelist2);
-
scm_init_freelist (&scm_i_master_freelist2, 2,
scm_getenv_int ("GUILE_MIN_YIELD_2", SCM_DEFAULT_MIN_YIELD_2));
scm_init_freelist (&scm_i_master_freelist, 1,
if (ptr)
return ptr;
- scm_rec_mutex_lock (&scm_i_sweep_mutex);
+ scm_pthread_mutex_lock (&scm_i_sweep_mutex);
scm_i_sweep_all_segments ("realloc");
SCM_SYSCALL (ptr = realloc (mem, size));
if (ptr)
{
- scm_rec_mutex_unlock (&scm_i_sweep_mutex);
+ pthread_mutex_unlock (&scm_i_sweep_mutex);
return ptr;
}
scm_igc ("realloc");
scm_i_sweep_all_segments ("realloc");
- scm_rec_mutex_unlock (&scm_i_sweep_mutex);
+ pthread_mutex_unlock (&scm_i_sweep_mutex);
SCM_SYSCALL (ptr = realloc (mem, size));
if (ptr)
static void
decrease_mtrigger (size_t size, const char * what)
{
- scm_i_plugin_mutex_lock (&scm_i_gc_admin_mutex);
+ pthread_mutex_lock (&scm_i_gc_admin_mutex);
scm_mallocated -= size;
scm_gc_malloc_collected += size;
- scm_i_plugin_mutex_unlock (&scm_i_gc_admin_mutex);
+ pthread_mutex_unlock (&scm_i_gc_admin_mutex);
}
static void
size_t mallocated = 0;
int overflow = 0, triggered = 0;
- scm_i_plugin_mutex_lock (&scm_i_gc_admin_mutex);
+ pthread_mutex_lock (&scm_i_gc_admin_mutex);
if (ULONG_MAX - size < scm_mallocated)
overflow = 1;
else
if (scm_mallocated > scm_mtrigger)
triggered = 1;
}
- scm_i_plugin_mutex_unlock (&scm_i_gc_admin_mutex);
+ pthread_mutex_unlock (&scm_i_gc_admin_mutex);
if (overflow)
- {
- scm_memory_error ("Overflow of scm_mallocated: too much memory in use.");
- }
+ scm_memory_error ("Overflow of scm_mallocated: too much memory in use.");
/*
A program that uses a lot of malloced collectable memory (vectors,
unsigned long prev_alloced;
float yield;
- scm_rec_mutex_lock (&scm_i_sweep_mutex);
+ scm_pthread_mutex_lock (&scm_i_sweep_mutex);
prev_alloced = mallocated;
scm_igc (what);
#endif
}
- scm_rec_mutex_unlock (&scm_i_sweep_mutex);
+ pthread_mutex_unlock (&scm_i_sweep_mutex);
}
}
*/
+
void
scm_gc_mark_dependencies (SCM p)
#define FUNC_NAME "scm_gc_mark_dependencies"
ptr = p;
scm_mark_dependencies_again:
-
+
cell_type = SCM_GC_CELL_TYPE (ptr);
switch (SCM_ITAG7 (cell_type))
{
abort();
}
}
-
- if (SCM_GC_MARK_P (ptr))
- {
- return;
- }
+
+ if (SCM_GC_MARK_P (ptr))
+ {
+ return;
+ }
SCM_SET_GC_MARK (ptr);
+
- goto scm_mark_dependencies_again;
+ goto scm_mark_dependencies_again;
}
#undef FUNC_NAME
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
+#define _GNU_SOURCE
/* #define DEBUGINFO */
/* Lock this mutex before doing lazy sweeping.
*/
-scm_t_rec_mutex scm_i_sweep_mutex;
+pthread_mutex_t scm_i_sweep_mutex = PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP;
/* Set this to != 0 if every cell that is accessed shall be checked:
*/
\f
-scm_t_key scm_i_freelist;
-scm_t_key scm_i_freelist2;
-
/* scm_mtrigger
* is the number of bytes of malloc allocation needed to trigger gc.
{
SCM cell;
- scm_rec_mutex_lock (&scm_i_sweep_mutex);
+ scm_pthread_mutex_lock (&scm_i_sweep_mutex);
*free_cells = scm_i_sweep_some_segments (freelist);
if (*free_cells == SCM_EOL && scm_i_gc_grow_heap_p (freelist))
*free_cells = SCM_FREE_CELL_CDR (cell);
- scm_rec_mutex_unlock (&scm_i_sweep_mutex);
+ pthread_mutex_unlock (&scm_i_sweep_mutex);
return cell;
}
void
scm_igc (const char *what)
{
- scm_rec_mutex_lock (&scm_i_sweep_mutex);
+ scm_pthread_mutex_lock (&scm_i_sweep_mutex);
++scm_gc_running_p;
scm_c_hook_run (&scm_before_gc_c_hook, 0);
*/
--scm_gc_running_p;
scm_c_hook_run (&scm_after_gc_c_hook, 0);
- scm_rec_mutex_unlock (&scm_i_sweep_mutex);
+ pthread_mutex_unlock (&scm_i_sweep_mutex);
/*
For debugging purposes, you could do
scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
}
-scm_t_mutex scm_i_gc_admin_mutex;
+pthread_mutex_t scm_i_gc_admin_mutex = PTHREAD_MUTEX_INITIALIZER;
int
scm_init_storage ()
{
size_t j;
- /* Fixme: Should use mutexattr from the low-level API. */
- scm_rec_mutex_init (&scm_i_sweep_mutex, &scm_i_plugin_rec_mutex);
-
- scm_i_plugin_mutex_init (&scm_i_gc_admin_mutex, &scm_i_plugin_mutex);
-
j = SCM_NUM_PROTECTS;
while (j)
scm_sys_protects[--j] = SCM_BOOL_F;
if (!scm_i_port_table)
return 1;
+#if 0
+ /* We can't have a cleanup handler since we have no thread to run it
+ in. */
+
#ifdef HAVE_ATEXIT
atexit (cleanup);
#else
#ifdef HAVE_ON_EXIT
on_exit (cleanup, 0);
#endif
+#endif
+
#endif
scm_stand_in_procs = scm_c_make_hash_table (257);
#include "libguile/__scm.h"
#include "libguile/hooks.h"
-
-#if SCM_USE_PTHREAD_THREADS
-# include "libguile/pthread-threads.h"
-#else
-# include "libguile/null-threads.h"
-#endif
+#include "libguile/threads.h"
\f
void scm_i_expensive_validation_check (SCM cell);
#endif
-SCM_API scm_t_mutex scm_i_gc_admin_mutex;
+SCM_API pthread_mutex_t scm_i_gc_admin_mutex;
SCM_API int scm_block_gc;
SCM_API int scm_gc_heap_lock;
SCM_API unsigned int scm_gc_running_p;
-SCM_API scm_t_rec_mutex scm_i_sweep_mutex;
+SCM_API pthread_mutex_t scm_i_sweep_mutex;
\f
#if (SCM_ENABLE_DEPRECATED == 1)
SCM_API size_t scm_max_segment_size;
-#define SCM_FREELIST_CREATE(key) \
- do { SCM *ls = (SCM *) malloc (sizeof (SCM)); \
- *ls = SCM_EOL; \
- scm_setspecific ((key), ls); } while (0)
-#define SCM_FREELIST_LOC(key) ((SCM *) scm_getspecific (key))
-SCM_API scm_t_key scm_i_freelist;
-SCM_API scm_t_key scm_i_freelist2;
+#define SCM_SET_FREELIST_LOC(key,ptr) pthread_setspecific ((key), (ptr))
+#define SCM_FREELIST_LOC(key) ((SCM *) pthread_getspecific (key))
+SCM_API pthread_key_t scm_i_freelist;
+SCM_API pthread_key_t scm_i_freelist2;
SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist;
SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2;
#include "libguile/hashtab.h"
\f
+static void
+loop (void)
+{
+ int loop = 1;
+ printf ("looping %d\n", getpid ());
+ while (loop)
+ ;
+}
+
+void
+scm_i_hashtable_decrement (SCM h)
+{
+ scm_t_hashtable *t = SCM_HASHTABLE (h);
+ if (t->n_items == 0)
+ {
+ printf ("hashtab underflow\n");
+ loop ();
+ }
+ t->n_items--;
+}
+
/* NOTES
*
* 1. The current hash table implementation uses weak alist vectors
SCM_HASHTABLE (table)->closure = closure;
}
SCM_HASHTABLE (table)->size_index = i;
-
+
new_size = hashtable_size[i];
if (i <= SCM_HASHTABLE (table)->min_size_index)
SCM_HASHTABLE (table)->lower = 0;
#define SCM_HASHTABLE_N_ITEMS(x) (SCM_HASHTABLE (x)->n_items)
#define SCM_SET_HASHTABLE_N_ITEMS(x, n) (SCM_HASHTABLE (x)->n_items = n)
#define SCM_HASHTABLE_INCREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)++)
+#if 0
#define SCM_HASHTABLE_DECREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)--)
+#else
+SCM_API void scm_i_hashtable_decrement (SCM h);
+#define SCM_HASHTABLE_DECREMENT(x) scm_i_hashtable_decrement(x)
+#endif
#define SCM_HASHTABLE_UPPER(x) (SCM_HASHTABLE (x)->upper)
#define SCM_HASHTABLE_LOWER(x) (SCM_HASHTABLE (x)->lower)
#include <unistd.h>
#endif
\f
-/* Setting up the stack. */
-
-static void
-restart_stack (void *base)
-{
- scm_dynwinds = SCM_EOL;
- SCM_DYNENV (scm_rootcont) = SCM_EOL;
- SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
- SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
- SCM_BASE (scm_rootcont) = base;
-}
-
-static void
-start_stack (void *base)
-{
- SCM root;
-
- root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
- scm_set_root (SCM_ROOT_STATE (root));
- scm_stack_base = base;
-
- scm_exitval = SCM_BOOL_F; /* vestigial */
-
- scm_root->fluids = scm_i_make_initial_fluids ();
-
- /* Create an object to hold the root continuation.
- */
- {
- scm_t_contregs *contregs = scm_gc_malloc (sizeof (scm_t_contregs),
- "continuation");
- contregs->num_stack_items = 0;
- contregs->seq = 0;
- SCM_NEWSMOB (scm_rootcont, scm_tc16_continuation, contregs);
- }
-
- /* The remainder of stack initialization is factored out to another
- * function so that if this stack is ever exitted, it can be
- * re-entered using restart_stack. */
- restart_stack (base);
-}
#if 0
char **argv; /* the argument list it should receive */
};
-
-static void scm_init_guile_1 (SCM_STACKITEM *base);
static void scm_boot_guile_1 (SCM_STACKITEM *base,
struct main_func_closure *closure);
-static SCM invoke_main_func(void *body_data);
+static void *invoke_main_func(void *body_data);
/* Fire up the Guile Scheme interpreter.
void
scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
{
- /* The garbage collector uses the address of this variable as one
- end of the stack, and the address of one of its own local
- variables as the other end. */
- SCM_STACKITEM dummy;
struct main_func_closure c;
c.main_func = main_func;
c.argc = argc;
c.argv = argv;
- scm_boot_guile_1 (&dummy, &c);
+ scm_with_guile (invoke_main_func, &c);
+}
+
+static void *
+invoke_main_func (void *body_data)
+{
+ struct main_func_closure *closure = (struct main_func_closure *) body_data;
+
+ scm_set_program_arguments (closure->argc, closure->argv, 0);
+ (*closure->main_func) (closure->closure, closure->argc, closure->argv);
+
+ scm_restore_signals ();
+
+ /* This tick gives any pending
+ * asyncs a chance to run. This must be done after
+ * the call to scm_restore_signals.
+ */
+ SCM_ASYNC_TICK;
+
+ /* If the caller doesn't want this, they should exit from main_func
+ themselves.
+ */
+ pthread_exit (NULL);
+
+ /* never reached */
+ return NULL;
}
+#if 0
void
scm_init_guile ()
{
- scm_init_guile_1 ((SCM_STACKITEM *)scm_get_stack_base ());
+ scm_i_init_guile ((SCM_STACKITEM *)scm_get_stack_base ());
}
+#endif
+pthread_mutex_t scm_i_init_mutex = PTHREAD_MUTEX_INITIALIZER;
int scm_initialized_p = 0;
-static void
-scm_init_guile_1 (SCM_STACKITEM *base)
+void
+scm_i_init_guile (SCM_STACKITEM *base)
{
if (scm_initialized_p)
return;
scm_block_gc = 1;
scm_storage_prehistory ();
- scm_threads_prehistory ();
+ scm_threads_prehistory (base);
scm_ports_prehistory ();
scm_smob_prehistory ();
scm_hashtab_prehistory (); /* requires storage_prehistory */
scm_init_variable (); /* all bindings need variables */
scm_init_continuations ();
scm_init_root (); /* requires continuations */
- scm_init_threads (base);
- start_stack (base);
+ scm_init_threads ();
scm_init_gsubr ();
scm_init_thread_procs (); /* requires gsubrs */
scm_init_procprop ();
scm_i_init_deprecated ();
#endif
+ scm_init_threads_root_root ();
+
scm_initialized_p = 1;
scm_block_gc = 0; /* permit the gc to run */
scm_load_startup_files ();
}
-/* Record here whether SCM_BOOT_GUILE_1 has already been called. This
- variable is now here and not inside SCM_BOOT_GUILE_1 so that one
- can tweak it. This is necessary for unexec to work. (Hey, "1-live"
- is the name of a local radiostation...) */
-
-int scm_boot_guile_1_live = 0;
-
-static void
-scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure)
-{
- scm_init_guile_1 (base);
-
- /* This function is not re-entrant. */
- if (scm_boot_guile_1_live)
- abort ();
-
- scm_boot_guile_1_live = 1;
-
- scm_set_program_arguments (closure->argc, closure->argv, 0);
- invoke_main_func (closure);
-
- scm_restore_signals ();
-
- /* This tick gives any pending
- * asyncs a chance to run. This must be done after
- * the call to scm_restore_signals.
- */
- SCM_ASYNC_TICK;
-
- /* If the caller doesn't want this, they should return from
- main_func themselves. */
- exit (0);
-}
-
-static SCM
-invoke_main_func (void *body_data)
-{
- struct main_func_closure *closure = (struct main_func_closure *) body_data;
-
- (*closure->main_func) (closure->closure, closure->argc, closure->argv);
-
- /* never reached */
- return SCM_UNDEFINED;
-}
/*
Local Variables:
\f
#include "libguile/__scm.h"
+#include "libguile/threads.h"
\f
+SCM_API pthread_mutex_t scm_i_init_mutex;
SCM_API int scm_initialized_p;
SCM_API void scm_init_guile (void);
char **argv),
void *closure);
+SCM_API void scm_i_init_guile (SCM_STACKITEM *base);
+
SCM_API void scm_load_startup_files (void);
#endif /* SCM_INIT_H */
scm_cell (scm_t_bits car, scm_t_bits cdr)
{
SCM z;
- /* We retrieve the SCM pointer only once since the call to
- SCM_FREELIST_LOC will be slightly expensive when we support
- preemptive multithreading. SCM_FREELIST_LOC will then retrieve
- the thread specific freelist.
-
- Until then, SCM_FREELIST_DOC expands to (&scm_i_freelist) and the
- following code will compile to the same as if we had worked
- directly on the scm_i_freelist variable.
- */
SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist);
if (scm_gc_running_p)
int_fd = scm_to_int (fd);
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_pthread_mutex_lock (&scm_i_port_table_mutex);
for (i = 0; i < scm_i_port_table_size; i++)
{
if (SCM_OPFPORTP (scm_i_port_table[i]->port)
&& ((scm_t_fport *) scm_i_port_table[i]->stream)->fdes == int_fd)
result = scm_cons (scm_i_port_table[i]->port, result);
}
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ pthread_mutex_unlock (&scm_i_port_table_mutex);
return result;
}
#undef FUNC_NAME
long scm_i_port_table_size = 0; /* Number of ports in scm_i_port_table. */
long scm_i_port_table_room = 20; /* Size of the array. */
-SCM_GLOBAL_MUTEX (scm_i_port_table_mutex);
+pthread_mutex_t scm_i_port_table_mutex = PTHREAD_MUTEX_INITIALIZER;
/* This function is not and should not be thread safe. */
rv = (scm_ptobs[i].close) (port);
else
rv = 0;
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_pthread_mutex_lock (&scm_i_port_table_mutex);
scm_remove_from_port_table (port);
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ pthread_mutex_unlock (&scm_i_port_table_mutex);
SCM_CLR_PORT_OPEN_FLAG (port);
return scm_from_bool (rv >= 0);
}
can change arbitrarily (from a GC, for example). So we first
collect the ports into a vector. -mvo */
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_pthread_mutex_lock (&scm_i_port_table_mutex);
n = scm_i_port_table_size;
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ pthread_mutex_unlock (&scm_i_port_table_mutex);
ports = scm_c_make_vector (n, SCM_BOOL_F);
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_pthread_mutex_lock (&scm_i_port_table_mutex);
if (n > scm_i_port_table_size)
n = scm_i_port_table_size;
for (i = 0; i < n; i++)
SCM_SIMPLE_VECTOR_SET (ports, i, scm_i_port_table[i]->port);
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ pthread_mutex_unlock (&scm_i_port_table_mutex);
for (i = 0; i < n; i++)
proc (data, SCM_SIMPLE_VECTOR_REF (ports, i));
{
size_t i;
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_pthread_mutex_lock (&scm_i_port_table_mutex);
for (i = 0; i < scm_i_port_table_size; i++)
{
if (SCM_OPOUTPORTP (scm_i_port_table[i]->port))
scm_flush (scm_i_port_table[i]->port);
}
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ pthread_mutex_unlock (&scm_i_port_table_mutex);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
static SCM
scm_i_void_port (long mode_bits)
{
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_pthread_mutex_lock (&scm_i_port_table_mutex);
{
SCM answer = scm_new_port_table_entry (scm_tc16_void_port);
scm_t_port * pt = SCM_PTAB_ENTRY(answer);
SCM_SETSTREAM (answer, 0);
SCM_SET_CELL_TYPE (answer, scm_tc16_void_port | mode_bits);
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ pthread_mutex_unlock (&scm_i_port_table_mutex);
return answer;
}
}
SCM_API scm_t_port **scm_i_port_table;
SCM_API long scm_i_port_table_size; /* Number of ports in scm_i_port_table. */
-SCM_API scm_t_mutex scm_i_port_table_mutex;
+SCM_API pthread_mutex_t scm_i_port_table_mutex;
#define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end)
#include "libguile/validate.h"
#include "libguile/posix.h"
#include "libguile/i18n.h"
+#include "libguile/threads.h"
\f
#ifdef HAVE_STRING_H
return SCM_BOOL_F;
fd = SCM_FPORT_FDES (port);
- scm_mutex_lock (&scm_i_misc_mutex);
+ scm_pthread_mutex_lock (&scm_i_misc_mutex);
SCM_SYSCALL (result = ttyname (fd));
err = errno;
ret = scm_from_locale_string (result);
- scm_mutex_unlock (&scm_i_misc_mutex);
+ pthread_mutex_unlock (&scm_i_misc_mutex);
if (!result)
{
char *c_key, *c_salt;
scm_frame_begin (0);
- scm_frame_unwind_handler ((void(*)(void*)) scm_mutex_unlock,
- &scm_i_misc_mutex,
- SCM_F_WIND_EXPLICITLY);
- scm_mutex_lock (&scm_i_misc_mutex);
+ scm_frame_pthread_mutex_lock (&scm_i_misc_mutex);
c_key = scm_to_locale_string (key);
scm_frame_free (c_key);
c_salt = scm_to_locale_string (salt);
- scm_frame_free (c_key);
+ scm_frame_free (c_salt);
ret = scm_from_locale_string (crypt (c_key, c_salt));
SCM scm_print_state_vtable = SCM_BOOL_F;
static SCM print_state_pool = SCM_EOL;
-SCM_MUTEX (print_state_mutex);
+pthread_mutex_t print_state_mutex = PTHREAD_MUTEX_INITIALIZER;
#ifdef GUILE_DEBUG /* Used for debugging purposes */
SCM answer = SCM_BOOL_F;
/* First try to allocate a print state from the pool */
- scm_i_plugin_mutex_lock (&print_state_mutex);
+ pthread_mutex_lock (&print_state_mutex);
if (!scm_is_null (print_state_pool))
{
answer = SCM_CAR (print_state_pool);
print_state_pool = SCM_CDR (print_state_pool);
}
- scm_i_plugin_mutex_unlock (&print_state_mutex);
+ pthread_mutex_unlock (&print_state_mutex);
return scm_is_false (answer) ? make_print_state () : answer;
}
pstate->fancyp = 0;
pstate->revealed = 0;
pstate->highlight_objects = SCM_EOL;
- scm_i_plugin_mutex_lock (&print_state_mutex);
+ pthread_mutex_lock (&print_state_mutex);
handle = scm_cons (print_state, print_state_pool);
print_state_pool = handle;
- scm_i_plugin_mutex_unlock (&print_state_mutex);
+ pthread_mutex_unlock (&print_state_mutex);
}
SCM
else
{
/* First try to allocate a print state from the pool */
- scm_i_plugin_mutex_lock (&print_state_mutex);
+ pthread_mutex_lock (&print_state_mutex);
if (!scm_is_null (print_state_pool))
{
handle = print_state_pool;
print_state_pool = SCM_CDR (print_state_pool);
}
- scm_i_plugin_mutex_unlock (&print_state_mutex);
+ pthread_mutex_unlock (&print_state_mutex);
if (scm_is_false (handle))
handle = scm_list_1 (make_print_state ());
pstate_scm = SCM_CAR (handle);
if (scm_is_true (handle) && !pstate->revealed)
{
- scm_i_plugin_mutex_lock (&print_state_mutex);
+ pthread_mutex_lock (&print_state_mutex);
SCM_SETCDR (handle, print_state_pool);
print_state_pool = handle;
- scm_i_plugin_mutex_unlock (&print_state_mutex);
+ pthread_mutex_unlock (&print_state_mutex);
}
}
scm_gc_mark (s->rootcont);
scm_gc_mark (s->dynwinds);
scm_gc_mark (s->progargs);
- scm_gc_mark (s->exitval);
scm_gc_mark (s->cur_inp);
scm_gc_mark (s->cur_outp);
scm_gc_mark (s->cur_errp);
root_state->rootcont
= root_state->dynwinds
= root_state->progargs
- = root_state->exitval
= root_state->cur_inp
= root_state->cur_outp
= root_state->cur_errp
\f
+/* Initialized in scm_threads_prehistory.
+ */
+pthread_key_t scm_i_root_key;
+
void
scm_init_root ()
{
/* It is very inefficient to have this variable in the root state. */
scm_t_debug_frame *last_debug_frame;
- SCM progargs; /* vestigial */
- SCM exitval; /* vestigial */
+ SCM progargs;
SCM cur_inp;
SCM cur_outp;
*/
} scm_root_state;
+#define scm_root ((scm_root_state *) pthread_getspecific (scm_i_root_key))
+#define scm_set_root(new_root) pthread_setspecific (scm_i_root_key, new_root)
+SCM_API pthread_key_t scm_i_root_key;
+
#define scm_stack_base (scm_root->stack_base)
#define scm_save_regs_gc_mark (scm_root->save_regs_gc_mark)
#define scm_errjmp_bad (scm_root->errjmp_bad)
#define scm_cur_errp (scm_root->cur_errp)
#define scm_cur_loadp (scm_root->cur_loadp)
-#define scm_root ((scm_root_state *) SCM_THREAD_LOCAL_DATA)
-#define scm_set_root(new_root) SCM_SET_THREAD_LOCAL_DATA (new_root)
\f
STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
}
-SCM_MUTEX (stringbuf_write_mutex);
+pthread_mutex_t stringbuf_write_mutex = PTHREAD_MUTEX_INITIALIZER;
/* Copy-on-write strings.
*/
SCM buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ pthread_mutex_unlock (&stringbuf_write_mutex);
return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
(scm_t_bits)str_start + start,
(scm_t_bits) end - start);
SCM buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ pthread_mutex_unlock (&stringbuf_write_mutex);
return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
(scm_t_bits)str_start + start,
(scm_t_bits) end - start);
if (IS_RO_STRING (str))
scm_misc_error (NULL, "string is read-only: ~s", scm_list_1 (orig_str));
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ pthread_mutex_lock (&stringbuf_write_mutex);
if (STRINGBUF_SHARED (buf))
{
/* Clone stringbuf. For this, we put all threads to sleep.
size_t len = STRING_LENGTH (str);
SCM new_buf;
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ pthread_mutex_unlock (&stringbuf_write_mutex);
new_buf = make_stringbuf (len);
memcpy (STRINGBUF_CHARS (new_buf),
buf = new_buf;
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ pthread_mutex_lock (&stringbuf_write_mutex);
}
return STRINGBUF_CHARS (buf) + start;
void
scm_i_string_stop_writing (void)
{
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ pthread_mutex_unlock (&stringbuf_write_mutex);
}
/* Symbols.
if (start == 0 && length == STRINGBUF_LENGTH (buf))
{
/* reuse buf. */
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ pthread_mutex_unlock (&stringbuf_write_mutex);
}
else
{
scm_i_symbol_substring (SCM sym, size_t start, size_t end)
{
SCM buf = SYMBOL_STRINGBUF (sym);
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ pthread_mutex_unlock (&stringbuf_write_mutex);
return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
(scm_t_bits)start, (scm_t_bits) end - start);
}
else
str = scm_c_substring (str, 0, str_len);
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_pthread_mutex_lock (&scm_i_port_table_mutex);
z = scm_new_port_table_entry (scm_tc16_strport);
pt = SCM_PTAB_ENTRY(z);
SCM_SETSTREAM (z, SCM_UNPACK (str));
pt->rw_random = 1;
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ pthread_mutex_unlock (&scm_i_port_table_mutex);
/* ensure write_pos is writable. */
if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
prefix = scm_from_locale_string (" g");
/* mutex in case another thread looks and incs at the exact same moment */
- scm_mutex_lock (&scm_i_misc_mutex);
+ scm_pthread_mutex_lock (&scm_i_misc_mutex);
n = gensym_counter++;
- scm_mutex_unlock (&scm_i_misc_mutex);
+ pthread_mutex_unlock (&scm_i_misc_mutex);
n_digits = scm_iint2str (n, 10, buf);
suffix = scm_from_locale_stringn (buf, n_digits);
\f
-/* This file implements nice Scheme level threads on top of the gastly
- C level threads.
-*/
-
#include "libguile/_scm.h"
#if HAVE_UNISTD_H
#include "libguile/threads.h"
#include "libguile/dynwind.h"
#include "libguile/iselect.h"
+#include "libguile/fluids.h"
+#include "libguile/continuations.h"
+#include "libguile/init.h"
/*** Queues */
/*** Threads */
-#define THREAD_INITIALIZED_P(t) (t->base != NULL)
-
-struct scm_thread {
-
- /* Blocking.
- */
- scm_t_cond sleep_cond;
- struct scm_thread *next_waiting;
-
- /* This mutex represents this threads right to access the heap.
- That right can temporarily be taken away by the GC. */
- scm_t_mutex heap_mutex;
- int clear_freelists_p; /* set if GC was done while thread was asleep */
-
- scm_root_state *root;
- SCM handle;
- scm_t_thread thread;
- SCM result;
- int exited;
-
- /* For keeping track of the stack and registers. */
- SCM_STACKITEM *base;
- SCM_STACKITEM *top;
- jmp_buf regs;
-
-};
-
-static SCM
-make_thread (SCM creation_protects)
-{
- SCM z;
- scm_thread *t;
- z = scm_make_smob (scm_tc16_thread);
- t = SCM_THREAD_DATA (z);
- t->handle = z;
- t->result = creation_protects;
- t->base = NULL;
- scm_i_plugin_cond_init (&t->sleep_cond, 0);
- scm_i_plugin_mutex_init (&t->heap_mutex, &scm_i_plugin_mutex);
- t->clear_freelists_p = 0;
- t->exited = 0;
- return z;
-}
-
-static void
-init_thread_creatant (SCM thread,
- SCM_STACKITEM *base)
-{
- scm_thread *t = SCM_THREAD_DATA (thread);
- t->thread = scm_thread_self ();
- t->base = base;
- t->top = NULL;
-}
-
static SCM
thread_mark (SCM obj)
{
scm_thread *t = SCM_THREAD_DATA (obj);
scm_gc_mark (t->result);
- return t->root->handle; /* mark root-state of this thread */
+ return t->root;
}
static int
{
scm_thread *t = SCM_THREAD_DATA (exp);
scm_puts ("#<thread ", port);
- scm_uintprint ((size_t)t->thread, 10, port);
+ scm_uintprint ((size_t)t->pthread, 10, port);
scm_puts (" (", port);
scm_uintprint ((scm_t_bits)t, 16, port);
scm_puts (")>", port);
thread_free (SCM obj)
{
scm_thread *t = SCM_THREAD_DATA (obj);
- if (!t->exited)
- abort ();
+ assert (t->exited);
scm_gc_free (t, sizeof (*t), "thread");
return 0;
}
/*** Scheduling */
#define cur_thread (SCM_CURRENT_THREAD->handle)
-scm_t_key scm_i_thread_key;
-scm_t_key scm_i_root_state_key;
+pthread_key_t scm_i_thread_key;
-void
-scm_i_set_thread_data (void *data)
-{
- scm_thread *t = SCM_CURRENT_THREAD;
- scm_setspecific (scm_i_root_state_key, data);
- t->root = (scm_root_state *)data;
-}
-
static void
resume (scm_thread *t)
{
}
}
-void
+static void
scm_i_enter_guile (scm_thread *t)
{
- scm_i_plugin_mutex_lock (&t->heap_mutex);
+ pthread_mutex_lock (&t->heap_mutex);
resume (t);
}
return c;
}
-scm_thread *
+static scm_thread *
scm_i_leave_guile ()
{
scm_thread *t = suspend ();
- scm_i_plugin_mutex_unlock (&t->heap_mutex);
+ pthread_mutex_unlock (&t->heap_mutex);
return t;
}
{
int err;
scm_thread *t = suspend ();
- err = scm_i_plugin_cond_wait (&t->sleep_cond, &t->heap_mutex);
+ err = pthread_cond_wait (&t->sleep_cond, &t->heap_mutex);
resume (t);
return err;
}
{
int err;
scm_thread *t = suspend ();
- err = scm_i_plugin_cond_timedwait (&t->sleep_cond, &t->heap_mutex, at);
+ err = pthread_cond_timedwait (&t->sleep_cond, &t->heap_mutex, at);
resume (t);
return err;
}
static void
unblock (scm_thread *t)
{
- scm_i_plugin_cond_signal (&t->sleep_cond);
+ pthread_cond_signal (&t->sleep_cond);
}
-/*** Thread creation */
+/* Getting into and out of guile mode.
+ */
-static scm_t_mutex thread_admin_mutex;
-static SCM all_threads;
+static pthread_mutex_t thread_admin_mutex = PTHREAD_MUTEX_INITIALIZER;
+static scm_thread *all_threads = NULL;
static int thread_count;
-typedef struct launch_data {
- SCM thread;
- SCM rootcont;
- scm_t_catch_body body;
- void *body_data;
- scm_t_catch_handler handler;
- void *handler_data;
-} launch_data;
+static void
+restart_stack (void *base)
+{
+ scm_dynwinds = SCM_EOL;
+ SCM_DYNENV (scm_rootcont) = SCM_EOL;
+ SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
+ SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
+ SCM_BASE (scm_rootcont) = base;
+}
-static SCM
-body_bootstrip (launch_data* data)
+static void
+start_stack (void *base)
{
- /* First save the new root continuation */
- data->rootcont = scm_root->rootcont;
- return (data->body) (data->body_data);
+ scm_stack_base = base;
+ scm_root->fluids = scm_i_make_initial_fluids ();
+
+ /* Create an object to hold the root continuation.
+ */
+ {
+ scm_t_contregs *contregs = scm_gc_malloc (sizeof (scm_t_contregs),
+ "continuation");
+ contregs->num_stack_items = 0;
+ contregs->seq = 0;
+ SCM_NEWSMOB (scm_rootcont, scm_tc16_continuation, contregs);
+ }
+
+ /* The remainder of stack initialization is factored out to another
+ * function so that if this stack is ever exitted, it can be
+ * re-entered using restart_stack. */
+ restart_stack (base);
}
-static SCM
-handler_bootstrip (launch_data* data, SCM tag, SCM throw_args)
+static SCM scm_i_root_root;
+
+static void
+guilify_self_1 (SCM_STACKITEM *base)
{
- scm_root->rootcont = data->rootcont;
- return (data->handler) (data->handler_data, tag, throw_args);
+ scm_thread *t = malloc (sizeof (scm_thread));
+
+ t->pthread = pthread_self ();
+ t->handle = SCM_BOOL_F;
+ t->root = SCM_BOOL_F;
+ t->result = SCM_BOOL_F;
+ t->base = base;
+ pthread_cond_init (&t->sleep_cond, NULL);
+ pthread_mutex_init (&t->heap_mutex, NULL);
+ t->clear_freelists_p = 0;
+ t->exited = 0;
+
+ t->freelist = SCM_EOL;
+ t->freelist2 = SCM_EOL;
+ SCM_SET_FREELIST_LOC (scm_i_freelist, &t->freelist);
+ SCM_SET_FREELIST_LOC (scm_i_freelist2, &t->freelist2);
+
+ pthread_setspecific (scm_i_thread_key, t);
+
+ pthread_mutex_lock (&t->heap_mutex);
+
+ pthread_mutex_lock (&thread_admin_mutex);
+ t->next_thread = all_threads;
+ all_threads = t;
+ thread_count++;
+ pthread_mutex_unlock (&thread_admin_mutex);
}
static void
-really_launch (SCM_STACKITEM *base, launch_data *data)
+guilify_self_2 (SCM parent)
{
- SCM thread;
- scm_thread *t;
- thread = data->thread;
- t = SCM_THREAD_DATA (thread);
- SCM_FREELIST_CREATE (scm_i_freelist);
- SCM_FREELIST_CREATE (scm_i_freelist2);
- scm_setspecific (scm_i_thread_key, t);
- scm_setspecific (scm_i_root_state_key, t->root);
- scm_i_plugin_mutex_lock (&t->heap_mutex); /* ensure that we "own" the heap */
- init_thread_creatant (thread, base); /* must own the heap */
-
- data->rootcont = SCM_BOOL_F;
- t->result =
- scm_internal_cwdr ((scm_t_catch_body) body_bootstrip,
- data,
- (scm_t_catch_handler) handler_bootstrip,
- data, base);
- scm_i_leave_guile (); /* release the heap */
- free (data);
-
- scm_i_plugin_mutex_lock (&thread_admin_mutex);
- all_threads = scm_delq_x (thread, all_threads);
+ scm_thread *t = SCM_CURRENT_THREAD;
+
+ SCM_NEWSMOB (t->handle, scm_tc16_thread, t);
+ scm_gc_register_collectable_memory (t, sizeof (scm_thread), "thread");
+ t->root = scm_make_root (SCM_BOOL_F);
+ scm_set_root (SCM_ROOT_STATE (t->root));
+ start_stack (t->base);
+
+ if (SCM_ROOTP (parent))
+ {
+ scm_root_state *thread_root = SCM_ROOT_STATE (t->root);
+ scm_root_state *parent_root = SCM_ROOT_STATE (parent);
+
+ thread_root->cur_inp = parent_root->cur_inp;
+ thread_root->cur_outp = parent_root->cur_outp;
+ thread_root->cur_errp = parent_root->cur_errp;
+ thread_root->fluids = parent_root->fluids;
+ scm_i_copy_fluids (thread_root);
+ }
+}
+
+static void
+on_thread_exit (void *v)
+{
+ scm_thread *t = (scm_thread *)v, **tp;
+
+ pthread_mutex_lock (&thread_admin_mutex);
t->exited = 1;
+ for (tp = &all_threads; *tp; tp = &(*tp)->next_thread)
+ if (*tp == t)
+ {
+ *tp = t->next_thread;
+ break;
+ }
thread_count--;
- /* detach before unlocking in order to not become joined when detached */
- scm_thread_detach (t->thread);
- scm_i_plugin_mutex_unlock (&thread_admin_mutex);
+ pthread_mutex_unlock (&thread_admin_mutex);
}
-static void *
-launch_thread (void *p)
+static void
+scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
{
- really_launch (SCM_STACK_PTR (&p), (launch_data *) p);
- return 0;
+ scm_thread *t;
+
+ pthread_mutex_lock (&scm_i_init_mutex);
+ if (scm_initialized_p == 0)
+ {
+ /* First thread ever to enter Guile. Run the full
+ initialization.
+ */
+ scm_i_init_guile (base);
+ }
+ else if ((t = SCM_CURRENT_THREAD) == NULL)
+ {
+ /* Guile is already initialized, but this thread enters it for
+ the first time. Only initialize this thread.
+ */
+ guilify_self_1 (base);
+ guilify_self_2 (parent);
+ }
+ else
+ {
+ /* This thread is already guilified, just resume it.
+ */
+ scm_i_enter_guile (t);
+ }
+ pthread_mutex_unlock (&scm_i_init_mutex);
}
-static SCM
-create_thread (scm_t_catch_body body, void *body_data,
- scm_t_catch_handler handler, void *handler_data,
- SCM protects)
+extern void *__libc_stack_end;
+
+static SCM_STACKITEM *
+get_thread_stack_base ()
{
- SCM thread;
+ pthread_attr_t attr;
+ void *start, *end;
+ size_t size;
+ int res;
- /* Make new thread. The first thing the new thread will do is to
- lock guile_mutex. Thus, we can safely complete its
- initialization after creating it. While the new thread starts,
- all its data is protected via all_threads.
- */
+ /* XXX - pthread_getattr_np does not seem to work for the main
+ thread, but we can use __libc_stack_end in that case.
+ */
- {
- scm_t_thread th;
- SCM root;
- launch_data *data;
- scm_thread *t;
- int err;
-
- /* Allocate thread locals. */
- root = scm_make_root (scm_root->handle);
- data = scm_malloc (sizeof (launch_data));
-
- /* Make thread. */
- thread = make_thread (protects);
- data->thread = thread;
- data->body = body;
- data->body_data = body_data;
- data->handler = handler;
- data->handler_data = handler_data;
- t = SCM_THREAD_DATA (thread);
- /* must initialize root state pointer before the thread is linked
- into all_threads */
- t->root = SCM_ROOT_STATE (root);
- /* disconnect from parent, to prevent remembering dead threads */
- t->root->parent = SCM_BOOL_F;
- /* start with an empty dynwind chain */
- t->root->dynwinds = SCM_EOL;
-
- /* In order to avoid the need of synchronization between parent
- and child thread, we need to insert the child into all_threads
- before creation. */
+ pthread_getattr_np (pthread_self (), &attr);
+ pthread_attr_getstack (&attr, &start, &size);
+ end = (char *)start + size;
+
+ if ((void *)&attr < start || (void *)&attr >= end)
+ return __libc_stack_end;
+ else
{
- SCM new_threads = scm_cons (thread, SCM_BOOL_F); /* could cause GC */
- scm_thread *parent = scm_i_leave_guile (); /* to prevent deadlock */
- scm_i_plugin_mutex_lock (&thread_admin_mutex);
- SCM_SETCDR (new_threads, all_threads);
- all_threads = new_threads;
- thread_count++;
- scm_i_plugin_mutex_unlock (&thread_admin_mutex);
-
- scm_remember_upto_here_1 (root);
-
- scm_i_enter_guile (parent);
+#if SCM_STACK_GROWS_UP
+ return start;
+#else
+ return end;
+#endif
}
-
- err = scm_i_plugin_thread_create (&th, 0, launch_thread, (void *) data);
- if (err != 0)
- {
- scm_i_plugin_mutex_lock (&thread_admin_mutex);
- all_threads = scm_delq_x (thread, all_threads);
- ((scm_thread *) SCM_THREAD_DATA(thread))->exited = 1;
- thread_count--;
- scm_i_plugin_mutex_unlock (&thread_admin_mutex);
- }
+}
- if (err)
- {
- errno = err;
- scm_syserror ("create-thread");
- }
- }
+void
+scm_init_guile ()
+{
+ scm_i_init_thread_for_guile (get_thread_stack_base (), scm_i_root_root);
+}
+
+void
+scm_enter_guile ()
+{
+ SCM_STACKITEM base_item;
+ scm_i_init_thread_for_guile (&base_item, scm_i_root_root);
+}
+
+void
+scm_leave_guile ()
+{
+ scm_i_leave_guile ();
+}
+
+void *
+scm_with_guile (void *(*func)(void *), void *data)
+{
+ return scm_i_with_guile_and_parent (func, data, scm_i_root_root);
+}
+
+void *
+scm_i_with_guile_and_parent (void *(*func)(void *), void *data,
+ SCM parent)
+{
+ void *res;
+ SCM_STACKITEM base_item;
+ scm_i_init_thread_for_guile (&base_item, parent);
+ res = func (data);
+ scm_i_leave_guile ();
+ return res;
+}
+
+void *
+scm_without_guile (void *(*func)(void *), void *data)
+{
+ void *res;
+ scm_thread *t;
+ t = scm_i_leave_guile ();
+ res = func (data);
+ scm_i_enter_guile (t);
+ return res;
+}
+
+/*** Thread creation */
+
+typedef struct {
+ SCM parent;
+ SCM thunk;
+ SCM handler;
+ SCM thread;
+ pthread_mutex_t mutex;
+ pthread_cond_t cond;
+} launch_data;
+
+static void *
+really_launch (void *d)
+{
+ launch_data *data = (launch_data *)d;
+ SCM thunk = data->thunk, handler = data->handler;
+ scm_thread *t;
+
+ t = SCM_CURRENT_THREAD;
+
+ pthread_mutex_lock (&data->mutex);
+ data->thread = scm_current_thread ();
+ pthread_cond_signal (&data->cond);
+ pthread_mutex_unlock (&data->mutex);
+
+ t->result = scm_catch (SCM_BOOL_T, thunk, handler);
- return thread;
+ t->exited = 1;
+ pthread_detach (t->pthread);
+
+ return 0;
+}
+
+static void *
+launch_thread (void *d)
+{
+ launch_data *data = (launch_data *)d;
+ return scm_i_with_guile_and_parent (really_launch, d, data->parent);
}
SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 2, 0, 0,
"All the evaluation rules for dynamic roots apply to threads.")
#define FUNC_NAME s_scm_call_with_new_thread
{
+ launch_data data;
+ pthread_t id;
+
SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), thunk, SCM_ARG1, FUNC_NAME);
SCM_ASSERT (scm_is_true (scm_procedure_p (handler)), handler, SCM_ARG2,
FUNC_NAME);
- return create_thread ((scm_t_catch_body) scm_call_0, thunk,
- (scm_t_catch_handler) scm_apply_1, handler,
- scm_cons (thunk, handler));
+ data.parent = scm_root->handle;
+ data.thunk = thunk;
+ data.handler = handler;
+ data.thread = SCM_BOOL_F;
+ pthread_mutex_init (&data.mutex, NULL);
+ pthread_cond_init (&data.cond, NULL);
+
+ pthread_mutex_lock (&data.mutex);
+ if (pthread_create (&id, NULL, launch_thread, &data))
+ {
+ pthread_mutex_unlock (&data.mutex);
+ SCM_SYSERROR;
+ }
+ pthread_cond_wait (&data.cond, &data.mutex);
+ pthread_mutex_unlock (&data.mutex);
+
+ return data.thread;
}
#undef FUNC_NAME
+typedef struct {
+ SCM parent;
+ scm_t_catch_body body;
+ void *body_data;
+ scm_t_catch_handler handler;
+ void *handler_data;
+ SCM thread;
+ pthread_mutex_t mutex;
+ pthread_cond_t cond;
+} spawn_data;
+
+static void *
+really_spawn (void *d)
+{
+ spawn_data *data = (spawn_data *)d;
+ scm_t_catch_body body = data->body;
+ void *body_data = data->body_data;
+ scm_t_catch_handler handler = data->handler;
+ void *handler_data = data->handler_data;
+ scm_thread *t = SCM_CURRENT_THREAD;
+
+ pthread_mutex_lock (&data->mutex);
+ data->thread = scm_current_thread ();
+ pthread_cond_signal (&data->cond);
+ pthread_mutex_unlock (&data->mutex);
+
+ t->result = scm_internal_catch (SCM_BOOL_T,
+ body, body_data,
+ handler, handler_data);
+
+ t->exited = 1;
+ pthread_detach (t->pthread);
+
+ return 0;
+}
+
+static void *
+spawn_thread (void *d)
+{
+ spawn_data *data = (spawn_data *)d;
+ return scm_i_with_guile_and_parent (really_spawn, d, data->parent);
+}
+
+SCM
+scm_spawn_thread (scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data)
+{
+ spawn_data data;
+ pthread_t id;
+
+ data.parent = scm_root->handle;
+ data.body = body;
+ data.body_data = body_data;
+ data.handler = handler;
+ data.handler_data = handler_data;
+ data.thread = SCM_BOOL_F;
+ pthread_mutex_init (&data.mutex, NULL);
+ pthread_cond_init (&data.cond, NULL);
+
+ pthread_mutex_lock (&data.mutex);
+ if (pthread_create (&id, NULL, spawn_thread, &data))
+ {
+ pthread_mutex_unlock (&data.mutex);
+ scm_syserror (NULL);
+ }
+ pthread_cond_wait (&data.cond, &data.mutex);
+ pthread_mutex_unlock (&data.mutex);
+
+ return data.thread;
+}
+
SCM_DEFINE (scm_yield, "yield", 0, 0, 0,
(),
"Move the calling thread to the end of the scheduling queue.")
#define FUNC_NAME s_scm_yield
{
- return scm_from_bool (scm_thread_yield ());
+ return scm_from_bool (sched_yield ());
}
#undef FUNC_NAME
{
scm_thread *c;
c = scm_i_leave_guile ();
- while (!THREAD_INITIALIZED_P (t))
- scm_i_plugin_thread_yield ();
- scm_thread_join (t->thread, 0);
+ pthread_join (t->pthread, 0);
scm_i_enter_guile (c);
}
res = t->result;
}
#undef FUNC_NAME
-/*** Fair mutexes */
+/*** Fat mutexes */
/* We implement our own mutex type since we want them to be 'fair', we
want to do fancy things while waiting for them (like running
Also, we might add things that are nice for debugging.
*/
-typedef struct fair_mutex {
- /* the thread currently owning the mutex, or SCM_BOOL_F. */
- scm_t_mutex lock;
- int lockedp;
+typedef struct {
+ pthread_mutex_t lock;
SCM owner;
- /* how much the owner owns us. */
- int level;
- /* the threads waiting for this mutex. */
- SCM waiting;
-} fair_mutex;
+ int level; /* how much the owner owns us.
+ < 0 for non-recursive mutexes */
+ SCM waiting; /* the threads waiting for this mutex. */
+} fat_mutex;
static SCM
-fair_mutex_mark (SCM mx)
+fat_mutex_mark (SCM mx)
{
- fair_mutex *m = SCM_MUTEX_DATA (mx);
+ fat_mutex *m = SCM_MUTEX_DATA (mx);
scm_gc_mark (m->owner);
return m->waiting;
}
-SCM_DEFINE (scm_make_fair_mutex, "make-fair-mutex", 0, 0, 0,
- (void),
- "Create a new fair mutex object. ")
-#define FUNC_NAME s_scm_make_fair_mutex
-{
- SCM mx = scm_make_smob (scm_tc16_fair_mutex);
- fair_mutex *m = SCM_MUTEX_DATA (mx);
- scm_i_plugin_mutex_init (&m->lock, &scm_i_plugin_mutex);
- m->lockedp = 0;
- m->owner = SCM_BOOL_F;
- m->level = 0;
- m->waiting = make_queue ();
- return mx;
-}
-#undef FUNC_NAME
-
-static int
-fair_mutex_lock (fair_mutex *m)
-{
- scm_i_plugin_mutex_lock (&m->lock);
-#if 0
- /* Need to wait if another thread is just temporarily unlocking.
- This is happens very seldom and only when the other thread is
- between scm_mutex_unlock and scm_i_plugin_mutex_lock below. */
- while (m->lockedp)
- SCM_TICK;
- m->lockedp = 1;
-#endif
-
- if (m->owner == SCM_BOOL_F)
- m->owner = cur_thread;
- else if (m->owner == cur_thread)
- m->level++;
- else
- {
- while (1)
- {
- SCM c = enqueue (m->waiting, cur_thread);
- int err;
- /* Note: It's important that m->lock is never locked for
- any longer amount of time since that could prevent GC */
- scm_i_plugin_mutex_unlock (&m->lock);
- err = block ();
- if (m->owner == cur_thread)
- return 0;
- scm_i_plugin_mutex_lock (&m->lock);
- remqueue (m->waiting, c);
- scm_i_plugin_mutex_unlock (&m->lock);
- if (err)
- return err;
- SCM_ASYNC_TICK;
- scm_i_plugin_mutex_lock (&m->lock);
- }
- }
- scm_i_plugin_mutex_unlock (&m->lock);
- return 0;
-}
-
-static int
-fair_mutex_trylock (fair_mutex *m)
-{
- scm_i_plugin_mutex_lock (&m->lock);
- if (m->owner == SCM_BOOL_F)
- m->owner = cur_thread;
- else if (m->owner == cur_thread)
- m->level++;
- else
- {
- scm_i_plugin_mutex_unlock (&m->lock);
- return EBUSY;
- }
- scm_i_plugin_mutex_unlock (&m->lock);
- return 0;
-}
-
-static int
-fair_mutex_unlock (fair_mutex *m)
-{
- scm_i_plugin_mutex_lock (&m->lock);
- if (m->owner != cur_thread)
- {
- scm_i_plugin_mutex_unlock (&m->lock);
- return EPERM;
- }
- else if (m->level > 0)
- m->level--;
- else
- {
- SCM next = dequeue (m->waiting);
- if (scm_is_true (next))
- {
- m->owner = next;
- unblock (SCM_THREAD_DATA (next));
- }
- else
- m->owner = SCM_BOOL_F;
- }
- scm_i_plugin_mutex_unlock (&m->lock);
- return 0;
-}
-
-/*** Fair condition variables */
-
-/* Like mutexes, we implement our own condition variables using the
- primitives above.
-*/
-
-typedef struct fair_cond {
- scm_t_mutex lock;
- /* the threads waiting for this condition. */
- SCM waiting;
-} fair_cond;
-
-static SCM
-fair_cond_mark (SCM cv)
-{
- fair_cond *c = SCM_CONDVAR_DATA (cv);
- return c->waiting;
-}
-
-SCM_DEFINE (scm_make_fair_condition_variable, "make-fair-condition-variable", 0, 0, 0,
- (void),
- "Make a new fair condition variable.")
-#define FUNC_NAME s_scm_make_fair_condition_variable
-{
- SCM cv = scm_make_smob (scm_tc16_fair_condvar);
- fair_cond *c = SCM_CONDVAR_DATA (cv);
- scm_i_plugin_mutex_init (&c->lock, 0);
- c->waiting = make_queue ();
- return cv;
-}
-#undef FUNC_NAME
-
-static int
-fair_cond_timedwait (fair_cond *c,
- fair_mutex *m,
- const scm_t_timespec *waittime)
-{
- int err;
- scm_i_plugin_mutex_lock (&c->lock);
-
- while (1)
- {
- enqueue (c->waiting, cur_thread);
- scm_i_plugin_mutex_unlock (&c->lock);
- fair_mutex_unlock (m); /*fixme* - not thread safe */
- if (waittime == NULL)
- err = block ();
- else
- err = timed_block (waittime);
- fair_mutex_lock (m);
- if (err)
- return err;
- /* XXX - check whether we have been signalled. */
- break;
- }
- return err;
-}
-
-static int
-fair_cond_signal (fair_cond *c)
+static size_t
+fat_mutex_free (SCM mx)
{
- SCM th;
- scm_i_plugin_mutex_lock (&c->lock);
- if (scm_is_true (th = dequeue (c->waiting)))
- unblock (SCM_THREAD_DATA (th));
- scm_i_plugin_mutex_unlock (&c->lock);
+ fat_mutex *m = SCM_MUTEX_DATA (mx);
+ pthread_mutex_destroy (&m->lock);
+ scm_gc_free (m, sizeof (fat_mutex), "mutex");
return 0;
}
static int
-fair_cond_broadcast (fair_cond *c)
+fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- SCM th;
- scm_i_plugin_mutex_lock (&c->lock);
- while (scm_is_true (th = dequeue (c->waiting)))
- unblock (SCM_THREAD_DATA (th));
- scm_i_plugin_mutex_unlock (&c->lock);
- return 0;
+ fat_mutex *m = SCM_MUTEX_DATA (mx);
+ scm_puts ("#<mutex ", port);
+ scm_uintprint ((scm_t_bits)m, 16, port);
+ scm_puts (">", port);
+ return 1;
}
+
+static SCM
+make_fat_mutex (int recursive)
+{
+ fat_mutex *m;
+ SCM mx;
-/*** Mutexes */
+ m = scm_gc_malloc (sizeof (fat_mutex), "mutex");
+ pthread_mutex_init (&m->lock, NULL);
+ m->owner = SCM_BOOL_F;
+ m->level = recursive? 0 : -1;
+ m->waiting = SCM_EOL;
+ SCM_NEWSMOB (mx, scm_tc16_mutex, (scm_t_bits) m);
+ m->waiting = make_queue ();
+ return mx;
+}
SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0,
(void),
- "Create a new mutex object. ")
+ "Create a new mutex. ")
#define FUNC_NAME s_scm_make_mutex
{
- SCM mx = scm_make_smob (scm_tc16_mutex);
- scm_i_plugin_mutex_init (SCM_MUTEX_DATA (mx), &scm_i_plugin_mutex);
- return mx;
+ return make_fat_mutex (0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0,
+ (void),
+ "Create a new recursive mutex. ")
+#define FUNC_NAME s_scm_make_recursive_mutex
+{
+ return make_fat_mutex (1);
}
#undef FUNC_NAME
-/*fixme* change documentation */
+static void
+fat_mutex_lock (fat_mutex *m)
+{
+ pthread_mutex_lock (&m->lock);
+
+ if (scm_is_false (m->owner))
+ m->owner = cur_thread;
+ else if (scm_is_eq (m->owner, cur_thread))
+ {
+ if (m->level >= 0)
+ m->level++;
+ else
+ {
+ pthread_mutex_unlock (&m->lock);
+ scm_misc_error (NULL, "mutex already locked by current thread",
+ SCM_EOL);
+ }
+ }
+ else
+ {
+ while (1)
+ {
+ SCM c = enqueue (m->waiting, cur_thread);
+ int err;
+ /* Note: It's important that m->lock is never locked for
+ any longer amount of time since that could prevent GC */
+ pthread_mutex_unlock (&m->lock);
+ err = block ();
+ if (scm_is_eq (m->owner, cur_thread))
+ return;
+ pthread_mutex_lock (&m->lock);
+ remqueue (m->waiting, c);
+ pthread_mutex_unlock (&m->lock);
+ if (err)
+ {
+ errno = err;
+ scm_syserror (NULL);
+ }
+ SCM_ASYNC_TICK;
+ pthread_mutex_lock (&m->lock);
+ }
+ }
+ pthread_mutex_unlock (&m->lock);
+}
+
SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
(SCM mx),
"Lock @var{mutex}. If the mutex is already locked, the calling thread "
"thread. That is, Guile's mutexes are @emph{recursive}. ")
#define FUNC_NAME s_scm_lock_mutex
{
- int err;
SCM_VALIDATE_MUTEX (1, mx);
- if (SCM_TYP16 (mx) == scm_tc16_fair_mutex)
- err = fair_mutex_lock (SCM_MUTEX_DATA (mx));
- else
+ fat_mutex_lock (SCM_MUTEX_DATA (mx));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+static int
+fat_mutex_trylock (fat_mutex *m)
+{
+ pthread_mutex_lock (&m->lock);
+ if (scm_is_false (m->owner))
+ m->owner = cur_thread;
+ else if (scm_is_eq (m->owner, cur_thread))
{
- scm_t_mutex *m = SCM_MUTEX_DATA (mx);
- err = scm_mutex_lock (m);
+ if (m->level >= 0)
+ m->level++;
+ else
+ {
+ pthread_mutex_unlock (&m->lock);
+ scm_misc_error (NULL, "mutex already locked by current thread",
+ SCM_EOL);
+ }
}
-
- if (err)
+ else
{
- errno = err;
- SCM_SYSERROR;
+ pthread_mutex_unlock (&m->lock);
+ return 0;
}
- return SCM_BOOL_T;
+ pthread_mutex_unlock (&m->lock);
+ return 1;
}
-#undef FUNC_NAME
SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0,
(SCM mx),
"else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
#define FUNC_NAME s_scm_try_mutex
{
- int err;
SCM_VALIDATE_MUTEX (1, mx);
- if (SCM_TYP16 (mx) == scm_tc16_fair_mutex)
- err = fair_mutex_trylock (SCM_MUTEX_DATA (mx));
- else
+ return scm_from_bool (fat_mutex_trylock (SCM_MUTEX_DATA (mx)));
+}
+#undef FUNC_NAME
+
+static void
+fat_mutex_unlock (fat_mutex *m)
+{
+ pthread_mutex_lock (&m->lock);
+ if (!scm_is_eq (m->owner, cur_thread))
{
- scm_t_mutex *m = SCM_MUTEX_DATA (mx);
- err = scm_mutex_trylock (m);
- }
+ const char *msg;
+ if (scm_is_false (m->owner))
+ msg = "mutex not locked";
+ else
+ msg = "mutex not locked by current thread";
- if (err == EBUSY)
- return SCM_BOOL_F;
-
- if (err)
+ pthread_mutex_unlock (&m->lock);
+ scm_misc_error (NULL, msg, SCM_EOL);
+ }
+ else if (m->level > 0)
+ m->level--;
+ else
{
- errno = err;
- SCM_SYSERROR;
+ SCM next = dequeue (m->waiting);
+ if (scm_is_true (next))
+ {
+ m->owner = next;
+ unblock (SCM_THREAD_DATA (next));
+ }
+ else
+ m->owner = SCM_BOOL_F;
}
-
- return SCM_BOOL_T;
+ pthread_mutex_unlock (&m->lock);
}
-#undef FUNC_NAME
SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0,
(SCM mx),
"@code{unlock-mutex} will actually unlock the mutex. ")
#define FUNC_NAME s_scm_unlock_mutex
{
- int err;
SCM_VALIDATE_MUTEX (1, mx);
- if (SCM_TYP16 (mx) == scm_tc16_fair_mutex)
- {
- err = fair_mutex_unlock (SCM_MUTEX_DATA (mx));
- if (err == EPERM)
- {
- fair_mutex *m = SCM_MUTEX_DATA (mx);
- if (m->owner != cur_thread)
- {
- if (m->owner == SCM_BOOL_F)
- SCM_MISC_ERROR ("mutex not locked", SCM_EOL);
- else
- SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL);
- }
- }
- }
- else
- {
- scm_t_mutex *m = SCM_MUTEX_DATA (mx);
- err = scm_mutex_unlock (m);
- }
-
- if (err)
- {
- errno = err;
- SCM_SYSERROR;
- }
+ fat_mutex_unlock (SCM_MUTEX_DATA (mx));
return SCM_BOOL_T;
}
#undef FUNC_NAME
-/*** Condition variables */
+/*** Fat condition variables */
+
+/* Like mutexes, we implement our own condition variables using the
+ primitives above.
+*/
+
+typedef struct {
+ pthread_mutex_t lock;
+ SCM waiting; /* the threads waiting for this condition. */
+} fat_cond;
+
+static SCM
+fat_cond_mark (SCM cv)
+{
+ fat_cond *c = SCM_CONDVAR_DATA (cv);
+ return c->waiting;
+}
+
+static size_t
+fat_cond_free (SCM mx)
+{
+ fat_cond *c = SCM_CONDVAR_DATA (mx);
+ pthread_mutex_destroy (&c->lock);
+ scm_gc_free (c, sizeof (fat_cond), "condition-variable");
+ return 0;
+}
+
+static int
+fat_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ fat_cond *c = SCM_CONDVAR_DATA (cv);
+ scm_puts ("#<condition-variable ", port);
+ scm_uintprint ((scm_t_bits)c, 16, port);
+ scm_puts (">", port);
+ return 1;
+}
SCM_DEFINE (scm_make_condition_variable, "make-condition-variable", 0, 0, 0,
(void),
"Make a new condition variable.")
#define FUNC_NAME s_scm_make_condition_variable
{
- SCM cv = scm_make_smob (scm_tc16_condvar);
- scm_i_plugin_cond_init (SCM_CONDVAR_DATA (cv), 0);
+ fat_cond *c;
+ SCM cv;
+
+ c = scm_gc_malloc (sizeof (fat_cond), "condition variable");
+ pthread_mutex_init (&c->lock, 0);
+ c->waiting = SCM_EOL;
+ SCM_NEWSMOB (cv, scm_tc16_condvar, (scm_t_bits) c);
+ c->waiting = make_queue ();
return cv;
}
#undef FUNC_NAME
+static void
+fat_cond_timedwait (fat_cond *c,
+ fat_mutex *m,
+ const scm_t_timespec *waittime)
+{
+ int err;
+ pthread_mutex_lock (&c->lock);
+
+ while (1)
+ {
+ enqueue (c->waiting, cur_thread);
+ pthread_mutex_unlock (&c->lock);
+ fat_mutex_unlock (m); /*fixme* - not thread safe */
+ if (waittime == NULL)
+ err = block ();
+ else
+ err = timed_block (waittime);
+ fat_mutex_lock (m);
+ if (err)
+ {
+ errno = err;
+ scm_syserror (NULL);
+ }
+ /* XXX - check whether we have been signalled. */
+ break;
+ }
+}
+
SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, 0,
(SCM cv, SCM mx, SCM t),
"Wait until @var{cond-var} has been signalled. While waiting, "
#define FUNC_NAME s_scm_timed_wait_condition_variable
{
scm_t_timespec waittime;
- int err;
SCM_VALIDATE_CONDVAR (1, cv);
SCM_VALIDATE_MUTEX (2, mx);
- if (!((SCM_TYP16 (cv) == scm_tc16_condvar
- && SCM_TYP16 (mx) == scm_tc16_mutex)
- || (SCM_TYP16 (cv) == scm_tc16_fair_condvar
- && SCM_TYP16 (mx) == scm_tc16_fair_mutex)))
- SCM_MISC_ERROR ("Condition variable and mutex are of different kinds.",
- SCM_EOL);
if (!SCM_UNBNDP (t))
{
if (scm_is_pair (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;
+ waittime.tv_sec = scm_to_ulong (SCM_CAR (t));
+ waittime.tv_nsec = scm_to_ulong (SCM_CAR (t)) * 1000;
}
else
{
- SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec);
+ waittime.tv_sec = scm_to_ulong (t);
waittime.tv_nsec = 0;
}
}
- if (SCM_TYP16 (cv) == scm_tc16_fair_condvar)
- err = fair_cond_timedwait (SCM_CONDVAR_DATA (cv),
- SCM_MUTEX_DATA (mx),
- SCM_UNBNDP (t) ? NULL : &waittime);
- else
- {
- scm_t_cond *c = SCM_CONDVAR_DATA (cv);
- scm_t_mutex *m = SCM_MUTEX_DATA (mx);
- if (SCM_UNBNDP (t))
- err = scm_cond_wait (c, m);
- else
- err = scm_cond_timedwait (c, m, &waittime);
- }
-
- if (err)
- {
- if (err == ETIMEDOUT)
- return SCM_BOOL_F;
- errno = err;
- SCM_SYSERROR;
- }
+ fat_cond_timedwait (SCM_CONDVAR_DATA (cv),
+ SCM_MUTEX_DATA (mx),
+ SCM_UNBNDP (t) ? NULL : &waittime);
return SCM_BOOL_T;
}
#undef FUNC_NAME
+static int
+fat_cond_signal (fat_cond *c)
+{
+ SCM th;
+ pthread_mutex_lock (&c->lock);
+ if (scm_is_true (th = dequeue (c->waiting)))
+ unblock (SCM_THREAD_DATA (th));
+ pthread_mutex_unlock (&c->lock);
+ return 0;
+}
+
SCM_DEFINE (scm_signal_condition_variable, "signal-condition-variable", 1, 0, 0,
(SCM cv),
"Wake up one thread that is waiting for @var{cv}")
#define FUNC_NAME s_scm_signal_condition_variable
{
SCM_VALIDATE_CONDVAR (1, cv);
- if (SCM_TYP16 (cv) == scm_tc16_fair_condvar)
- fair_cond_signal (SCM_CONDVAR_DATA (cv));
- else
- {
- scm_t_cond *c = SCM_CONDVAR_DATA (cv);
- scm_cond_signal (c);
- }
+ fat_cond_signal (SCM_CONDVAR_DATA (cv));
return SCM_BOOL_T;
}
#undef FUNC_NAME
+static int
+fat_cond_broadcast (fat_cond *c)
+{
+ SCM th;
+ pthread_mutex_lock (&c->lock);
+ while (scm_is_true (th = dequeue (c->waiting)))
+ unblock (SCM_THREAD_DATA (th));
+ pthread_mutex_unlock (&c->lock);
+ return 0;
+}
+
SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1, 0, 0,
(SCM cv),
"Wake up all threads that are waiting for @var{cv}. ")
#define FUNC_NAME s_scm_broadcast_condition_variable
{
SCM_VALIDATE_CONDVAR (1, cv);
- if (SCM_TYP16 (cv) == scm_tc16_fair_condvar)
- fair_cond_broadcast (SCM_CONDVAR_DATA (cv));
- else
- {
- scm_t_cond *c = SCM_CONDVAR_DATA (cv);
- scm_cond_broadcast (c);
- }
+ fat_cond_broadcast (SCM_CONDVAR_DATA (cv));
return SCM_BOOL_T;
}
#undef FUNC_NAME
void
scm_threads_mark_stacks (void)
{
- volatile SCM c;
-
- for (c = all_threads; !scm_is_null (c); c = SCM_CDR (c))
+ scm_thread *t;
+ for (t = all_threads; t; t = t->next_thread)
{
- scm_thread *t = SCM_THREAD_DATA (SCM_CAR (c));
- if (!THREAD_INITIALIZED_P (t))
- {
- /* Not fully initialized yet. */
- continue;
- }
+ /* Check that thread has indeed been suspended.
+ */
+ assert (t->top);
- if (t->top == NULL)
- {
- /* Thread has not been suspended, which should never happen.
- */
- abort ();
- }
+ scm_gc_mark (t->handle);
- {
#if SCM_STACK_GROWS_UP
- scm_mark_locations (t->base, t->top - t->base);
+ scm_mark_locations (t->base, t->top - t->base);
#else
- scm_mark_locations (t->top, t->base - t->top);
+ scm_mark_locations (t->top, t->base - t->top);
#endif
- }
scm_mark_locations ((SCM_STACKITEM *) t->regs,
((size_t) sizeof(t->regs)
/ sizeof (SCM_STACKITEM)));
{
int res, eno;
scm_thread *c = scm_i_leave_guile ();
- res = scm_i_plugin_select (nfds, readfds, writefds, exceptfds, timeout);
+ res = select (nfds, readfds, writefds, exceptfds, timeout);
eno = errno;
scm_i_enter_guile (c);
SCM_ASYNC_TICK;
return res;
}
-/* Low-level C API */
-
-SCM
-scm_spawn_thread (scm_t_catch_body body, void *body_data,
- scm_t_catch_handler handler, void *handler_data)
-{
- return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F);
-}
-
-scm_t_thread
-scm_c_scm2thread (SCM thread)
-{
- return SCM_THREAD_DATA (thread)->thread;
-}
+/* Convenience API */
int
-scm_mutex_lock (scm_t_mutex *m)
+scm_pthread_mutex_lock (pthread_mutex_t *mutex)
{
scm_thread *t = scm_i_leave_guile ();
- int res = scm_i_plugin_mutex_lock (m);
+ int res = pthread_mutex_lock (mutex);
scm_i_enter_guile (t);
return res;
}
-scm_t_rec_mutex *
-scm_make_rec_mutex ()
+static void
+unlock (void *data)
{
- scm_t_rec_mutex *m = scm_malloc (sizeof (scm_t_rec_mutex));
- scm_i_plugin_rec_mutex_init (m, &scm_i_plugin_rec_mutex);
- return m;
+ pthread_mutex_unlock ((pthread_mutex_t *)data);
}
void
-scm_rec_mutex_free (scm_t_rec_mutex *m)
-{
- scm_i_plugin_rec_mutex_destroy (m);
- free (m);
-}
-
-int
-scm_rec_mutex_lock (scm_t_rec_mutex *m)
+scm_frame_pthread_mutex_lock (pthread_mutex_t *mutex)
{
- scm_thread *t = scm_i_leave_guile ();
- int res = scm_i_plugin_rec_mutex_lock (m);
- scm_i_enter_guile (t);
- return res;
+ scm_pthread_mutex_lock (mutex);
+ scm_frame_unwind_handler (unlock, mutex, SCM_F_WIND_EXPLICITLY);
}
int
-scm_cond_wait (scm_t_cond *c, scm_t_mutex *m)
+scm_pthread_cond_wait (pthread_cond_t *cond, pthread_mutex_t *mutex)
{
scm_thread *t = scm_i_leave_guile ();
- scm_i_plugin_cond_wait (c, m);
+ int res = pthread_cond_wait (cond, mutex);
scm_i_enter_guile (t);
- return 0;
+ return res;
}
int
-scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m, const scm_t_timespec *wt)
+scm_pthread_cond_timedwait (pthread_cond_t *cond,
+ pthread_mutex_t *mutex,
+ const scm_t_timespec *wt)
{
scm_thread *t = scm_i_leave_guile ();
- int res = scm_i_plugin_cond_timedwait (c, m, wt);
+ int res = pthread_cond_timedwait (cond, mutex, wt);
scm_i_enter_guile (t);
return res;
}
-void *
-scm_getspecific (scm_t_key k)
-{
- return scm_i_plugin_getspecific (k);
-}
-
-int
-scm_setspecific (scm_t_key k, void *s)
-{
- return scm_i_plugin_setspecific (k, s);
-}
-
-void
-scm_enter_guile ()
-{
- scm_i_enter_guile (SCM_CURRENT_THREAD);
-}
-
-void
-scm_leave_guile ()
-{
- scm_i_leave_guile ();
-}
-
unsigned long
scm_thread_usleep (unsigned long usecs)
{
}
#undef FUNC_NAME
+static SCM
+scm_c_make_list (size_t n, SCM fill)
+{
+ SCM res = SCM_EOL;
+ while (n-- > 0)
+ res = scm_cons (fill, res);
+ return res;
+}
+
SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0,
(void),
"Return a list of all threads.")
#define FUNC_NAME s_scm_all_threads
{
- return scm_list_copy (all_threads);
+ /* We can not allocate while holding the thread_admin_mutex because
+ of the way GC is done.
+ */
+ int n = thread_count;
+ scm_thread *t;
+ SCM list = scm_c_make_list (n, SCM_UNSPECIFIED), *l;
+
+ pthread_mutex_lock (&thread_admin_mutex);
+ l = &list;
+ for (t = all_threads; t && n > 0; t = t->next_thread)
+ {
+ SCM_SETCAR (*l, t->handle);
+ l = SCM_CDRLOC (*l);
+ n--;
+ }
+ *l = SCM_EOL;
+ pthread_mutex_unlock (&thread_admin_mutex);
+ return list;
}
#undef FUNC_NAME
scm_root_state *
scm_i_thread_root (SCM thread)
{
- return ((scm_thread *) SCM_THREAD_DATA (thread))->root;
+ return SCM_ROOT_STATE ((SCM_CURRENT_THREAD)->root);
}
SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0,
}
#undef FUNC_NAME
-static scm_t_cond wake_up_cond;
+static pthread_cond_t wake_up_cond;
int scm_i_thread_go_to_sleep;
static int threads_initialized_p = 0;
{
if (threads_initialized_p)
{
- SCM threads;
+ scm_thread *t;
/* We leave Guile completely before locking the
thread_admin_mutex. This ensures that other threads can put
us to sleep while we block on that mutex.
*/
scm_i_leave_guile ();
- scm_i_plugin_mutex_lock (&thread_admin_mutex);
- threads = all_threads;
+ pthread_mutex_lock (&thread_admin_mutex);
/* Signal all threads to go to sleep */
scm_i_thread_go_to_sleep = 1;
- for (; !scm_is_null (threads); threads = SCM_CDR (threads))
- {
- scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
- scm_i_plugin_mutex_lock (&t->heap_mutex);
- }
+ for (t = all_threads; t; t = t->next_thread)
+ pthread_mutex_lock (&t->heap_mutex);
scm_i_thread_go_to_sleep = 0;
}
}
void
scm_i_thread_invalidate_freelists ()
{
- /* Don't need to lock thread_admin_mutex here since we are single threaded */
- SCM threads = all_threads;
- for (; !scm_is_null (threads); threads = SCM_CDR (threads))
- if (SCM_CAR (threads) != cur_thread)
- {
- scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
- t->clear_freelists_p = 1;
- }
+ /* thread_admin_mutex is already locked. */
+
+ scm_thread *t;
+ for (t = all_threads; t; t = t->next_thread)
+ if (t != SCM_CURRENT_THREAD)
+ t->clear_freelists_p = 1;
}
void
{
if (threads_initialized_p)
{
- SCM threads;
- threads = all_threads;
- scm_i_plugin_cond_broadcast (&wake_up_cond);
- for (; !scm_is_null (threads); threads = SCM_CDR (threads))
- {
- scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
- scm_i_plugin_mutex_unlock (&t->heap_mutex);
- }
- scm_i_plugin_mutex_unlock (&thread_admin_mutex);
+ scm_thread *t;
+ pthread_cond_broadcast (&wake_up_cond);
+ for (t = all_threads; t; t = t->next_thread)
+ pthread_mutex_unlock (&t->heap_mutex);
+ pthread_mutex_unlock (&thread_admin_mutex);
scm_i_enter_guile (SCM_CURRENT_THREAD);
}
}
{
scm_thread *t;
t = suspend ();
- scm_i_plugin_cond_wait (&wake_up_cond, &t->heap_mutex);
+ pthread_cond_wait (&wake_up_cond, &t->heap_mutex);
resume (t);
}
-scm_t_mutex scm_i_critical_section_mutex;
-scm_t_rec_mutex scm_i_defer_mutex;
-
-#if SCM_USE_PTHREAD_THREADS
-# include "libguile/pthread-threads.c"
-#endif
-#include "libguile/threads-plugin.c"
+pthread_mutex_t scm_i_critical_section_mutex = PTHREAD_MUTEX_INITIALIZER;
/*** Initialization */
+pthread_key_t scm_i_freelist, scm_i_freelist2;
+pthread_mutex_t scm_i_misc_mutex;
+
void
-scm_threads_prehistory ()
-{
- scm_thread *t;
-#if SCM_USE_PTHREAD_THREADS
- /* Must be called before any initialization of a mutex. */
- scm_init_pthread_threads ();
-#endif
- scm_i_plugin_mutex_init (&thread_admin_mutex, &scm_i_plugin_mutex);
- scm_i_plugin_cond_init (&wake_up_cond, 0);
- scm_i_plugin_mutex_init (&scm_i_critical_section_mutex, &scm_i_plugin_mutex);
- thread_count = 1;
- scm_i_plugin_key_create (&scm_i_thread_key, 0);
- scm_i_plugin_key_create (&scm_i_root_state_key, 0);
- scm_i_plugin_rec_mutex_init (&scm_i_defer_mutex, &scm_i_plugin_rec_mutex);
- /* Allocate a fake thread object to be used during bootup. */
- t = malloc (sizeof (scm_thread));
- t->base = NULL;
- t->clear_freelists_p = 0;
- scm_i_plugin_mutex_init (&t->heap_mutex, &scm_i_plugin_mutex);
- scm_setspecific (scm_i_thread_key, t);
- scm_i_enter_guile (t);
+scm_threads_prehistory (SCM_STACKITEM *base)
+{
+ pthread_mutex_init (&thread_admin_mutex, NULL);
+ pthread_mutex_init (&scm_i_misc_mutex, NULL);
+ pthread_cond_init (&wake_up_cond, NULL);
+ pthread_mutex_init (&scm_i_critical_section_mutex, NULL);
+ pthread_key_create (&scm_i_thread_key, on_thread_exit);
+ pthread_key_create (&scm_i_root_key, NULL);
+ pthread_key_create (&scm_i_freelist, NULL);
+ pthread_key_create (&scm_i_freelist2, NULL);
+
+ guilify_self_1 (base);
}
scm_t_bits scm_tc16_thread;
-scm_t_bits scm_tc16_future;
scm_t_bits scm_tc16_mutex;
-scm_t_bits scm_tc16_fair_mutex;
scm_t_bits scm_tc16_condvar;
-scm_t_bits scm_tc16_fair_condvar;
void
-scm_init_threads (SCM_STACKITEM *base)
+scm_init_threads ()
{
- SCM thread;
scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_thread));
- scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_t_mutex));
- scm_tc16_fair_mutex = scm_make_smob_type ("fair-mutex",
- sizeof (fair_mutex));
- scm_tc16_condvar = scm_make_smob_type ("condition-variable",
- sizeof (scm_t_cond));
- scm_tc16_fair_condvar = scm_make_smob_type ("fair-condition-variable",
- sizeof (fair_cond));
-
- thread = make_thread (SCM_BOOL_F);
- /* Replace initial fake thread with a real thread object */
- free (SCM_CURRENT_THREAD);
- scm_setspecific (scm_i_thread_key, SCM_THREAD_DATA (thread));
- scm_i_enter_guile (SCM_CURRENT_THREAD);
-
- /* root is set later from init.c */
- init_thread_creatant (thread, base);
- thread_count = 1;
- scm_gc_register_root (&all_threads);
- all_threads = scm_cons (thread, SCM_EOL);
-
scm_set_smob_mark (scm_tc16_thread, thread_mark);
scm_set_smob_print (scm_tc16_thread, thread_print);
scm_set_smob_free (scm_tc16_thread, thread_free);
- scm_set_smob_mark (scm_tc16_fair_mutex, fair_mutex_mark);
+ scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (fat_mutex));
+ scm_set_smob_mark (scm_tc16_mutex, fat_mutex_mark);
+ scm_set_smob_print (scm_tc16_mutex, fat_mutex_print);
+ scm_set_smob_free (scm_tc16_mutex, fat_mutex_free);
- scm_set_smob_mark (scm_tc16_fair_condvar, fair_cond_mark);
+ scm_tc16_condvar = scm_make_smob_type ("condition-variable",
+ sizeof (fat_cond));
+ scm_set_smob_mark (scm_tc16_condvar, fat_cond_mark);
+ scm_set_smob_print (scm_tc16_condvar, fat_cond_print);
+ scm_set_smob_free (scm_tc16_condvar, fat_cond_free);
+ scm_i_root_root = SCM_BOOL_F;
+ guilify_self_2 (SCM_BOOL_F);
threads_initialized_p = 1;
}
-/* scm_i_misc_mutex is intended for miscellaneous uses, to protect
- operations which are non-reentrant or non-thread-safe but which are
- either not important enough or not used often enough to deserve their own
- private mutex. */
-SCM_GLOBAL_MUTEX (scm_i_misc_mutex);
+void
+scm_init_threads_root_root ()
+{
+ scm_root_state *rr;
+
+ scm_i_root_root = scm_permanent_object (scm_make_root (SCM_BOOL_F));
+ rr = SCM_ROOT_STATE (scm_i_root_root);
+ rr->cur_inp = scm_cur_inp;
+ rr->cur_outp = scm_cur_outp;
+ rr->cur_errp = scm_cur_errp;
+ rr->fluids = scm_root->fluids;
+ scm_i_copy_fluids (rr);
+}
void
scm_init_thread_procs ()
#include "libguile/throw.h"
#include "libguile/root.h"
#include "libguile/iselect.h"
-#include "libguile/threads-plugin.h"
+
+#include <pthread.h>
+
\f
/* smob tags for the thread datatypes */
SCM_API scm_t_bits scm_tc16_thread;
SCM_API scm_t_bits scm_tc16_mutex;
-SCM_API scm_t_bits scm_tc16_fair_mutex;
SCM_API scm_t_bits scm_tc16_condvar;
-SCM_API scm_t_bits scm_tc16_fair_condvar;
+
+typedef struct scm_thread {
+ struct scm_thread *next_thread;
+
+ /* For general blocking.
+ */
+ pthread_cond_t sleep_cond;
+
+ /* This mutex represents this threads right to access the heap.
+ That right can temporarily be taken away by the GC.
+ */
+ pthread_mutex_t heap_mutex;
+ SCM freelist, freelist2;
+ int clear_freelists_p; /* set if GC was done while thread was asleep */
+
+ SCM root;
+
+ SCM handle;
+ pthread_t pthread;
+ SCM result;
+ int exited;
+
+ /* For keeping track of the stack and registers. */
+ SCM_STACKITEM *base;
+ SCM_STACKITEM *top;
+ jmp_buf regs;
+
+} scm_thread;
#define SCM_THREADP(x) SCM_SMOB_PREDICATE (scm_tc16_thread, x)
#define SCM_THREAD_DATA(x) ((scm_thread *) SCM_SMOB_DATA (x))
#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
-#define SCM_FAIR_MUTEX_P(x) SCM_SMOB_PREDICATE (scm_tc16_fair_mutex, x)
#define SCM_MUTEX_DATA(x) ((void *) SCM_SMOB_DATA (x))
#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
-#define SCM_FAIR_CONDVAR_P(x) SCM_SMOB_PREDICATE (scm_tc16_fair_condvar, x)
#define SCM_CONDVAR_DATA(x) ((void *) SCM_SMOB_DATA (x))
#define SCM_VALIDATE_THREAD(pos, a) \
SCM_MAKE_VALIDATE_MSG (pos, a, THREADP, "thread")
#define SCM_VALIDATE_MUTEX(pos, a) \
- SCM_ASSERT_TYPE (SCM_MUTEXP (a) || SCM_FAIR_MUTEX_P (a), \
+ SCM_ASSERT_TYPE (SCM_MUTEXP (a), \
a, pos, FUNC_NAME, "mutex");
#define SCM_VALIDATE_CONDVAR(pos, a) \
- SCM_ASSERT_TYPE (SCM_CONDVARP (a) || SCM_FAIR_CONDVAR_P (a), \
+ SCM_ASSERT_TYPE (SCM_CONDVARP (a), \
a, pos, FUNC_NAME, "condition variable");
-SCM_API void scm_threads_mark_stacks (void);
-SCM_API void scm_init_threads (SCM_STACKITEM *);
-SCM_API void scm_init_thread_procs (void);
-
-#if SCM_USE_PTHREAD_THREADS
-# include "libguile/pthread-threads.h"
-#else
-# include "libguile/null-threads.h"
-#endif
-
-/*----------------------------------------------------------------------*/
-/* Low-level C API */
-
-/* The purpose of this API is seamless, simple and thread package
- independent interaction with Guile threads from the application.
-
- Note that Guile also uses it to implement itself, just like
- with the rest of the application API.
- */
-
-/* MDJ 021209 <djurfeldt@nada.kth.se>:
- The separation of the plugin interface (currently in
- pthread-threads.h and null-threads.h) and the low-level C API needs
- to be completed in a sensible way.
- */
-
-/* Deprecate this name and rename to scm_thread_create?
- Introduce the other two arguments in pthread_create to prepare for
- the future?
- */
SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data,
scm_t_catch_handler handler, void *handler_data);
-SCM_API scm_t_thread scm_c_scm2thread (SCM thread);
-
-#define scm_thread_join scm_i_plugin_thread_join
-#define scm_thread_detach scm_i_plugin_thread_detach
-#define scm_thread_self scm_i_plugin_thread_self
-#define scm_thread_yield scm_i_plugin_thread_yield
-
-#define scm_mutex_init scm_i_plugin_mutex_init
-#define scm_mutex_destroy scm_i_plugin_mutex_destroy
-SCM_API int scm_mutex_lock (scm_t_mutex *m);
-#define scm_mutex_trylock scm_i_plugin_mutex_trylock
-#define scm_mutex_unlock scm_i_plugin_mutex_unlock
-
-/* Guile itself needs recursive mutexes. See for example the
- implentation of scm_force in eval.c.
-
- Note that scm_rec_mutex_lock et al can be replaced by direct usage
- of the corresponding pthread functions if we use the pthread
- debugging API to access the stack top (in which case there is no
- longer any need to save the top of the stack before blocking).
-
- It's therefore highly motivated to use these calls in situations
- where Guile or the application needs recursive mutexes.
- */
-#define scm_rec_mutex_init scm_i_plugin_rec_mutex_init
-#define scm_rec_mutex_destroy scm_i_plugin_rec_mutex_destroy
-/* It's a safer bet to use the following functions.
- The future of the _init functions is uncertain.
- */
-SCM_API scm_t_rec_mutex *scm_make_rec_mutex (void);
-SCM_API void scm_rec_mutex_free (scm_t_rec_mutex *);
-SCM_API int scm_rec_mutex_lock (scm_t_rec_mutex *m);
-#define scm_rec_mutex_trylock scm_i_plugin_rec_mutex_trylock
-#define scm_rec_mutex_unlock scm_i_plugin_rec_mutex_unlock
-
-#define scm_cond_init scm_i_plugin_cond_init
-#define scm_cond_destroy scm_i_plugin_cond_destroy
-SCM_API int scm_cond_wait (scm_t_cond *c, scm_t_mutex *m);
-SCM_API int scm_cond_timedwait (scm_t_cond *c,
- scm_t_mutex *m,
- const scm_t_timespec *t);
-#define scm_cond_signal scm_i_plugin_cond_signal
-#define scm_cond_broadcast scm_i_plugin_cond_broadcast
-
-#define scm_key_create scm_i_plugin_key_create
-#define scm_key_delete scm_i_plugin_key_delete
-SCM_API int scm_setspecific (scm_t_key k, void *s);
-SCM_API void *scm_getspecific (scm_t_key k);
-
-#define scm_thread_select scm_internal_select
/* The application must scm_leave_guile() before entering any piece of
- code which can
- 1. block, or
- 2. execute for any longer period of time without calling SCM_TICK
-
- Note, though, that it is *not* necessary to use these calls
- together with any call in this API.
+ code which can block.
*/
SCM_API void scm_enter_guile (void);
SCM_API void scm_leave_guile (void);
-/* Better versions (although we need the former ones also in order to
- avoid forcing code restructuring in existing applications): */
-/*fixme* Not implemented yet! */
-SCM_API void *scm_in_guile (void (*func) (void*), void *data);
-SCM_API void *scm_outside_guile (void (*func) (void*), void *data);
-
-/* These are versions of the ordinary sleep and usleep functions
- that play nicely with the thread system. */
-SCM_API unsigned long scm_thread_sleep (unsigned long);
-SCM_API unsigned long scm_thread_usleep (unsigned long);
-
-/* End of low-level C API */
-/*----------------------------------------------------------------------*/
-
-typedef struct scm_thread scm_thread;
-
-SCM_API void scm_i_enter_guile (scm_thread *t);
-SCM_API scm_thread *scm_i_leave_guile (void);
+SCM_API void *scm_with_guile (void *(*func)(void *), void *data);
+SCM_API void *scm_without_guile (void *(*func)(void *), void *data);
+SCM_API void *scm_i_with_guile_and_parent (void *(*func)(void *), void *data,
+ SCM parent);
/* Critical sections */
/* This is the generic critical section for places where we are too
lazy to allocate a specific mutex. */
-extern scm_t_mutex scm_i_critical_section_mutex;
+extern pthread_mutex_t scm_i_critical_section_mutex;
#define SCM_CRITICAL_SECTION_START \
- scm_mutex_lock (&scm_i_critical_section_mutex)
+ scm_pthread_mutex_lock (&scm_i_critical_section_mutex)
#define SCM_CRITICAL_SECTION_END \
- scm_mutex_unlock (&scm_i_critical_section_mutex)
-
-/* This is the temporary support for the old ALLOW/DEFER ints sections */
-extern scm_t_rec_mutex scm_i_defer_mutex;
+ pthread_mutex_unlock (&scm_i_critical_section_mutex)
extern int scm_i_thread_go_to_sleep;
void scm_i_thread_wake_up (void);
void scm_i_thread_invalidate_freelists (void);
void scm_i_thread_sleep_for_gc (void);
-void scm_threads_prehistory (void);
+void scm_threads_prehistory (SCM_STACKITEM *);
void scm_threads_init_first_thread (void);
+SCM_API void scm_threads_mark_stacks (void);
+SCM_API void scm_init_threads (void);
+SCM_API void scm_init_thread_procs (void);
+SCM_API void scm_init_threads_root_root (void);
#define SCM_THREAD_SWITCHING_CODE \
do { \
SCM_API SCM scm_yield (void);
SCM_API SCM scm_join_thread (SCM t);
SCM_API SCM scm_make_mutex (void);
-SCM_API SCM scm_make_fair_mutex (void);
+SCM_API SCM scm_make_recursive_mutex (void);
SCM_API SCM scm_lock_mutex (SCM m);
SCM_API SCM scm_try_mutex (SCM m);
SCM_API SCM scm_unlock_mutex (SCM m);
SCM_API SCM scm_make_condition_variable (void);
-SCM_API SCM scm_make_fair_condition_variable (void);
SCM_API SCM scm_wait_condition_variable (SCM cond, SCM mutex);
SCM_API SCM scm_timed_wait_condition_variable (SCM cond, SCM mutex,
SCM abstime);
SCM_API scm_root_state *scm_i_thread_root (SCM thread);
#define SCM_CURRENT_THREAD \
- ((scm_thread *) scm_i_plugin_getspecific (scm_i_thread_key))
-extern scm_t_key scm_i_thread_key;
+ ((scm_thread *) pthread_getspecific (scm_i_thread_key))
+SCM_API pthread_key_t scm_i_thread_key;
+
+SCM_API pthread_mutex_t scm_i_misc_mutex;
-/* These macros have confusing names.
- They really refer to the root state of the running thread. */
-#define SCM_THREAD_LOCAL_DATA (scm_getspecific (scm_i_root_state_key))
-#define SCM_SET_THREAD_LOCAL_DATA(x) scm_i_set_thread_data(x)
-SCM_API scm_t_key scm_i_root_state_key;
-SCM_API void scm_i_set_thread_data (void *);
+/* Convenience functions for working with the pthread API in guile
+ mode.
+*/
-SCM_API scm_t_mutex scm_i_misc_mutex;
+SCM_API int scm_pthread_mutex_lock (pthread_mutex_t *mutex);
+SCM_API void scm_frame_pthread_mutex_lock (pthread_mutex_t *mutex);
+SCM_API int scm_pthread_cond_wait (pthread_cond_t *cond,
+ pthread_mutex_t *mutex);
+SCM_API int scm_pthread_cond_timedwait (pthread_cond_t *cond,
+ pthread_mutex_t *mutex,
+ const struct timespec *abstime);
+SCM_API unsigned long scm_thread_sleep (unsigned long);
+SCM_API unsigned long scm_thread_usleep (unsigned long);
#endif /* SCM_THREADS_H */
}
handler_message (handler_data, tag, args);
- exit (2);
+ pthread_exit (NULL);
}
SCM_ASSERT ((vlen == 5) || (vlen == 6), pv, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, modes);
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_pthread_mutex_lock (&scm_i_port_table_mutex);
z = scm_new_port_table_entry (scm_tc16_sfport);
pt = SCM_PTAB_ENTRY (z);
scm_port_non_buffer (pt);
SCM_SET_CELL_TYPE (z, scm_tc16_sfport | scm_i_mode_bits (modes));
SCM_SETSTREAM (z, SCM_UNPACK (pv));
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ pthread_mutex_unlock (&scm_i_port_table_mutex);
return z;
}
#undef FUNC_NAME
HCoop / bpt / guile.git / commitdiff