summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMarius Vollmer <mvo@zagadka.de>2005-03-02 20:42:01 +0000
committerMarius Vollmer <mvo@zagadka.de>2005-03-02 20:42:01 +0000
commit9de87eea47536e25ef99bc25f07afdd759ee3575 (patch)
tree936d52588ace67469aba68f6ad47cbf1a12462ca
parentcb1cfc42a4f5ac4d60a64b425795432a0388ad7e (diff)
downloadguile-9de87eea47536e25ef99bc25f07afdd759ee3575.tar.gz
See ChangeLog from 2005-03-02.
-rw-r--r--libguile/ChangeLog216
-rw-r--r--libguile/__scm.h71
-rw-r--r--libguile/async.c201
-rw-r--r--libguile/async.h7
-rw-r--r--libguile/backtrace.c15
-rw-r--r--libguile/continuations.c141
-rw-r--r--libguile/continuations.h27
-rw-r--r--libguile/coop-threads.c0
-rw-r--r--libguile/debug.c14
-rw-r--r--libguile/deprecated.c103
-rw-r--r--libguile/deprecated.h56
-rw-r--r--libguile/discouraged.h7
-rw-r--r--libguile/dynl.c8
-rw-r--r--libguile/dynwind.c40
-rw-r--r--libguile/error.c5
-rw-r--r--libguile/eval.c157
-rw-r--r--libguile/eval.h3
-rw-r--r--libguile/filesys.c6
-rw-r--r--libguile/fluids.c429
-rw-r--r--libguile/fluids.h63
-rw-r--r--libguile/fports.c10
-rw-r--r--libguile/futures.c59
-rw-r--r--libguile/futures.h4
-rw-r--r--libguile/gc-freelist.c6
-rw-r--r--libguile/gc-malloc.c22
-rw-r--r--libguile/gc.c94
-rw-r--r--libguile/gc.h22
-rw-r--r--libguile/gh.h4
-rw-r--r--libguile/goops.c8
-rw-r--r--libguile/guardians.c29
-rw-r--r--libguile/init.c178
-rw-r--r--libguile/init.h4
-rw-r--r--libguile/ioext.c4
-rw-r--r--libguile/iselect.h20
-rw-r--r--libguile/keywords.c4
-rw-r--r--libguile/null-threads.c327
-rw-r--r--libguile/null-threads.h156
-rw-r--r--libguile/objprop.c4
-rw-r--r--libguile/ports.c132
-rw-r--r--libguile/ports.h3
-rw-r--r--libguile/posix.c12
-rw-r--r--libguile/print.c28
-rw-r--r--libguile/pthread-threads.h102
-rw-r--r--libguile/rdelim.c4
-rw-r--r--libguile/read.c2
-rw-r--r--libguile/regex-posix.c4
-rw-r--r--libguile/root.c171
-rw-r--r--libguile/root.h60
-rw-r--r--libguile/rw.c6
-rw-r--r--libguile/scmsigs.c251
-rw-r--r--libguile/smob.c4
-rw-r--r--libguile/srcprop.c4
-rw-r--r--libguile/srfi-4.c4
-rw-r--r--libguile/stackchk.c21
-rw-r--r--libguile/stackchk.h4
-rw-r--r--libguile/stacks.c4
-rw-r--r--libguile/stime.c34
-rw-r--r--libguile/strings.c26
-rw-r--r--libguile/strports.c4
-rw-r--r--libguile/struct.c8
-rw-r--r--libguile/symbols.c4
-rw-r--r--libguile/threads.c1788
-rw-r--r--libguile/threads.h292
-rw-r--r--libguile/throw.c63
-rw-r--r--libguile/unif.c4
-rw-r--r--libguile/validate.h3
-rw-r--r--libguile/vports.c4
67 files changed, 3004 insertions, 2566 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 899bb86b4..06d2cbb01 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,219 @@
+2005-03-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ Big merge from the mvo-thread-cleanup branch. The main changes
+ are:
+
+ - The dynamic roots functionality has been split into dynamic
+ states and continuations barriers. Fluids have been
+ reimplemented and can now be garbage collected.
+
+ - Initialization of Guile now works in a multi-thread friendly
+ manner. Threads can freely enter and leave guile mode.
+
+ - Blocking on mutexes or condition variables or while selecting
+ can now be reliably interrupted via system asyncs.
+
+ - The low-level threading interface has been removed.
+
+ - Signals are delivered via a pipe to a dedicated 'signal delivery
+ thread'.
+
+ - SCM_DEFER_INTS, SCM_ALLOW_INTS etc have been deprecated.
+
+ * throw.c (scm_handle_by_message): Exit only the current thread,
+ not the whole process.
+ (scm_handle_by_message_noexit): Exit when catching 'quit.
+
+ * scmsigs.c (take_signal, signal_delivery_thread,
+ start_signal_delivery_thread, ensure_signal_delivery_thread,
+ install_handler): Reimplemented signal delivery as explained in
+ the comments.
+
+ * pthreads-threads.h (scm_i_pthread_t, scm_i_pthread_self,
+ scm_i_pthread_create, scm_i_pthread_detach, scm_i_pthread_exit,
+ scm_i_sched_yield, scm_i_pthread_sigmask,
+ SCM_I_PTHREAD_MUTEX_INITIALIZER,
+ SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER, scm_i_pthread_mutex_t ,
+ scm_i_pthread_mutex_init, scm_i_pthread_mutex_destroy,
+ scm_i_pthread_mutex_trylock, scm_i_pthread_mutex_lock,
+ scm_i_pthread_mutex_unlock, SCM_I_PTHREAD_COND_INITIALIZER,
+ scm_i_pthread_cond_t, scm_i_pthread_cond_init,
+ scm_i_pthread_cond_destroy, scm_i_pthread_cond_signal,
+ scm_i_pthread_cond_broadcast, scm_i_pthread_cond_wait,
+ scm_i_pthread_cond_timedwait, scm_i_pthread_once_t,
+ SCM_I_PTHREAD_ONCE_INIT, scm_i_pthread_once, scm_i_pthread_key_t ,
+ scm_i_pthread_key_create, scm_i_pthread_setspecific,
+ scm_i_pthread_getspecific, scm_i_scm_pthread_mutex_lock,
+ scm_i_frame_pthread_mutex_lock, scm_i_scm_pthread_cond_wait,
+ scm_i_scm_pthread_cond_timedwait): Provide the obvious mapping
+ when using pthreads.
+ * null-threads.c, null-threads.h: Provide dummy definitions for
+ the above symbols when not using pthreads.
+
+ * modules.h, modules.c (scm_frame_current_module): New.
+
+ * load.c (scm_primitive_load): Use scm_i_frame_current_load_port
+ instead of scm_internal_dynamic_wind.
+
+ * init.h, init.c (restart_stack, start_stack): Removed.
+ (scm_boot_guile, invoke_main_func): Simply use scm_with_guile.
+ (scm_boot_guile_1): Removed.
+ (scm_i_init_mutex): New.
+ (really_cleanup_for_exit, cleanup_for_exit): New.
+ (scm_init_guile_1, scm_i_init_guile): Renamed former to latter.
+ Moved around some init funcs. Call
+ scm_init_threads_default_dynamic_state. Register cleanup_for_exit
+ with atexit.
+
+ * hashtab.c (scm_hash_fn_create_handle_x, scm_hash_fn_remove_x):
+ Use "!scm_is_eq" instead of "!=".
+
+ * ge-scmconfig.c, gen-scmconfig.h.in (SCM_I_GSC_USE_COOP_THREADS,
+ SCM_USE_COOP_THREADS): Removed.
+
+ * gc.c (scm_igc): Take care that scm_gc_running_p is properly
+ maintained. Unlock scm_i_sweep_mutex before running
+ scm_after_gc_c_hook.
+ (scm_permanent_object): Allocate outside of critical section.
+ (cleanup): Removed.
+
+ * fluids.h, fluids.c: Reimplemented completely.
+ (SCM_FLUID_NUM, SCM_FAST_FLUID_REF,
+ SCM_FAST_FLUID_SET): Reimplemented as functions.
+ (scm_is_fluid): New.
+ (scm_i_make_initial_fluids, scm_i_copy_fluids): Removed.
+ (scm_make_dynamic_state, scm_dynamic_state_p,
+ scm_is_dynamic_state, scm_current_dynamic_state,
+ scm_set_current_dynamic_state, scm_frame_current_dynamic_state,
+ scm_c_with_dynamic_state, scm_with_dynamic_state,
+ scm_i_make_initial_dynamic_state, scm_fluids_prehistory): New.
+
+ * feature.c (progargs_fluid): New.
+ (scm_program_arguments, scm_set_program_arguments): Use it instead
+ of scm_progargs.
+ (scm_init_feature): Allocate it. Also, only add "threads" feature
+ when SCM_USE_PTHREAD_THREADS is true.
+
+ * eval.c (scm_makprom): Use scm_make_recursive_mutex instead of
+ scm_make_rec_mutex, with all the consequences.
+ (scm_eval_x, scm_eval): Use scm_frame_begin etc instead of
+ scm_internal_dynamic_wind. Handle dynamic states as second
+ argument.
+
+ * threads.h, threads.c (scm_internal_select): Renamed to
+ scm_std_select and discouraged old name.
+ (scm_thread_sleep, scm_thread_usleep): Likewise, as scm_std_sleep
+ and scm_std_usleep.
+ (scm_tc16_fair_mutex, scm_tc16_fair_condvar, SCM_MUTEXP,
+ SCM_FAIR_MUTEX_P, SCM_MUTEX_DATA, SCM_CONDVARP,
+ SCM_FAIR_CONDVAR_P, SCM_CONDVAR_DATA, SCM_THREADP,
+ SCM_THREAD_DATA): Removed.
+ (SCM_I_IS_THREAD, SCM_I_THREAD_DATA): New.
+ (scm_i_thread): New.
+ (SCM_VALIDATE_THREAD, SCM_VALIDATE_MUTEX, SCM_VALIDATE_CONDVAR):
+ Use scm_assert_smob_type.
+ (scm_c_scm2thread, scm_thread_join, scm_thread_detach,
+ scm_thread_self, scm_thread_yield, scm_mutex_init,
+ scm_mutex_destroy, scm_mutex_trylock, scm_mutex_unlock,
+ scm_rec_mutex_init, scm_rec_mutex_destroy, scm_make_rec_mutex,
+ scm_rec_mutex_free, scm_rec_mutex_lock, scm_rec_mutex_trylock,
+ scm_cond_init, scm_cond_destroy, scm_cond_wait,
+ scm_cond_timedwait, scm_cond_signal, scm_cond_broadcast,
+ scm_key_create, scm_key_delete, scm_setspecific, scm_getspecific,
+ scm_thread_select): Removed. Replaced with scm_i_pthread
+ functions as appropriate.
+ (scm_in_guile, scm_outside_guile): Removed.
+ (scm_t_guile_ticket, scm_leave_guile, scm_enter_guile): Return and
+ take a ticket.
+ (scm_with_guile, scm_without_guile, scm_i_with_guile_and_parent):
+ New.
+ (scm_i_frame_single_threaded): New.
+ (scm_init_threads_default_dynamic_state): New.
+ (scm_i_create_thread): Removed.
+ (scm_make_fair_mutex, scm_make_fair_condition_variable): Removed.
+ (scm_make_recursive_mutex): New.
+ (scm_frame_critical_section): New.
+ (SCM_CURRENT_THREAD, SCM_I_CURRENT_THREAD): Renamed former to
+ latter, changed all uses.
+ (scm_i_dynwinds, scm_i_setdynwinds, scm_i_last_debug_frame,
+ scm_i_set_last_debug_frame): New, use them instead of scm_root
+ stuff.
+ (SCM_THREAD_LOCAL_DATA, SCM_SET_THREAD_LOCAL_DATA,
+ scm_i_root_state_key,m scm_i_set_thread_data): Removed.
+ (scm_pthread_mutex_lock, scm_frame_pthread_mutex_lock,
+ scm_pthread_cond_wait, scm_pthread_cond_timedwait).
+ (remqueue): Allow the removal of already removed cells. Indicate
+ whether a real removal has happened.
+ (scm_thread): Removed, replaced with scm_i_thread.
+ (make_thread, init_thread_creatant): Removed.
+ (cur_thread): Removed.
+ (block_self, unblock_from_queue): New.
+ (block, timed_block, unblock): Removed.
+ (guilify_self_1, guilify_self_2, do_thread_exit,
+ init_thread_key_once, init_thread_key,
+ scm_i_init_thread_for_guile, get_thread_stack_base,
+ scm_init_guile): New initialisation method.
+ (scm_call_with_new_thread, scm_spawn_thread): Use it to simplify
+ thread creation.
+ (fair_mutex, fat_mutex, etc, fair_condvar, fat_condvar): Renamed
+ "fair" to fat and implemented new semantics, including reliable
+ interruption.
+ (all_threads): Now a pointer to a scm_i_thread, not a SCM.
+ (scm_threads_mark_stacks): Explicitly mark handle.
+ (scm_std_select): Allow interruption by also selecting on the
+ sleep_pipe.
+ (scm_i_thread_put_to_sleep): Handle recursive requests for
+ single-threadedness.
+ (scm_threads_prehistory, scm_init_threads): Put current thread
+ into guile mode via guileify_self_1 and guileify_self_2,
+ respectively.
+
+ * fluid.h (SCM_FLUIDP): Deprecated.
+
+ * coop-threads.c: Removed.
+
+ * continuations.h, continuations.c (scm_with_continuation_barrier,
+ scm_c_with_continuation_barrier, scm_i_with_continuation_barrier):
+ New.
+
+ * async.h, async.c (scm_i_setup_sleep, scm_i_reset_sleep): New.
+ (async_mutex): New.
+ (scm_async_click): Protected with async_mutex. Do not deal with
+ signal_asyncs, which are gone. Set cdr of handled async cell to
+ #f.
+ (scm_i_queue_async_cell): Protected with async_mutex. Interrupt
+ current sleep.
+ (scm_system_async_mark_for_thread): Do not use scm_current_thread
+ since that might not work during early initialization.
+
+ * __scm.h (SCM_DEFER_INTS, SCM_ALLOW_INTS, SCM_REDEFER_INTS,
+ SCM_REALLOW_INTS): Deprecated by moving into deprecated.h and
+ deprecated.c. Replaced all uses with SCM_CRITICAL_SECTION_START
+ and SCM_CRITICAL_SECTION_END.
+ (SCM_ENTER_A_SECTION, SCM_EXIT_A_SECTION): Removed. Replaced with
+ SCM_CRITICAL_SECTION_START/END.
+
+ * Makefile.am (modinclude_HEADER): Removed threads-plugin.h.
+ (libguile_la_SOURCES): Added null-threads.c
+ (EXTRA_libguile_la_SOURCES): Removed pthread-threads.c and
+ threads-plugin.c.
+ * pthread-threads.c, threads-plugin.c, threads-plugin.h: Removed.
+
+ * root.h, root.c (scm_tc16_root, SCM_ROOTP, SCM_ROOT_STATE,
+ scm_root_state, scm_stack_base, scm_save_regs_gc_mark,
+ scm_errjmp_bad, scm_rootcont, scm_dynwinds, scm_progargs,
+ scm_last_debug_frame, scm_exitval, scm_cur_inp, scm_outp,
+ scm_cur_err, scm_cur_loadp, scm_root, scm_set_root,
+ scm_make_root): Removed or deprecated. Replaced with references
+ to the current thread, dynamic state, continuation barrier, or
+ some fluid, as appropriate.
+ (root_mark, root_print): Removed.
+ (scm_internal_cwdr): Reimplemented guts with
+ scm_frame_current_dynamic_state and
+ scm_i_with_continuation_barrier.
+ (scm_dynamic_root): Return current continuation barrier.
+
+
2005-02-28 Marius Vollmer <mvo@zagadka.de>
* socket.c (scm_setsockopt): Handle IP_ADD_MEMBERSHIP and
diff --git a/libguile/__scm.h b/libguile/__scm.h
index 6ab774cd6..d86ec85a2 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -454,7 +454,7 @@ typedef long SCM_STACKITEM;
#define SCM_ASYNC_TICK /*fixme* should change names */ \
do { \
- if (scm_root->pending_asyncs) \
+ if (SCM_I_CURRENT_THREAD->pending_asyncs) \
scm_async_click (); \
} while (0)
@@ -482,40 +482,6 @@ do { \
#define SCM_FENCE
#endif
-/* In the old days, SCM_DEFER_INTS stopped signal handlers from running,
- since in those days the handler directly ran scheme code, and that had to
- be avoided when the heap was not in a consistent state etc. And since
- the scheme code could do a stack swapping new continuation etc, signals
- had to be deferred around various C library functions which were not safe
- or not known to be safe to swap away, which was a lot of stuff.
-
- These days signals are implemented with asyncs and don't directly run
- scheme code in the handler, but hold it until an SCM_TICK etc where it
- will be safe. This means interrupt protection is not needed and
- SCM_DEFER_INTS / SCM_ALLOW_INTS is something of an anachronism.
-
- What past SCM_DEFER_INTS usage also did though was indicate code that was
- not reentrant, ie. could not be reentered by signal handler code. The
- present definitions are a mutex lock, affording that reentrancy
- protection against the new guile 1.8 free-running posix threads.
-
- One big problem with the present defintions though is that code which
- throws an error from within a DEFER/ALLOW region will leave the
- defer_mutex locked and hence hang other threads that attempt to enter a
- similar DEFER/ALLOW region.
-
- The plan is to migrate reentrancy protection to an explicit mutex
- (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_ALLOW_INTS scm_rec_mutex_unlock (&scm_i_defer_mutex);
-
-#define SCM_REDEFER_INTS SCM_DEFER_INTS
-
-#define SCM_REALLOW_INTS SCM_ALLOW_INTS
-
#define SCM_TICK \
do { \
SCM_ASYNC_TICK; \
@@ -524,41 +490,6 @@ do { \
-/* Note: The following needs updating. */
-
-/* Classification of critical sections
- *
- * When Guile moves to POSIX threads, it won't be possible to prevent
- * context switching. In fact, the whole idea of context switching is
- * bogus if threads are run by different processors. Therefore, we
- * must ultimately eliminate all critical sections or enforce them by
- * use of mutecis.
- *
- * All instances of SCM_DEFER_INTS and SCM_ALLOW_INTS should therefore
- * be classified and replaced by one of the delimiters below. If you
- * understand what this is all about, I'd like to encourage you to
- * help with this task. The set of classes below must of course be
- * incrementally augmented.
- *
- * MDJ 980419 <djurfeldt@nada.kth.se>
- */
-
-/* A sections
- *
- * Allocation of a cell with type tag in the CAR.
- *
- * With POSIX threads, each thread will have a private pool of free
- * cells. Therefore, this type of section can be removed. But! It
- * is important that the CDR is initialized first (with the CAR still
- * indicating a free cell) so that we can guarantee a consistent heap
- * at all times.
- */
-
-#define SCM_ENTER_A_SECTION SCM_CRITICAL_SECTION_START
-#define SCM_EXIT_A_SECTION SCM_CRITICAL_SECTION_END
-
-
-
/** SCM_ASSERT
**
**/
diff --git a/libguile/async.c b/libguile/async.c
index 35e8a5a66..88375f577 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -136,39 +136,39 @@ SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0,
+static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
/* System asyncs. */
void
scm_async_click ()
{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ SCM asyncs;
+
/* Reset pending_asyncs even when asyncs are blocked and not really
- executed.
+ executed since this will avoid future futile calls to this
+ function. When asyncs are unblocked again, this function is
+ invoked even when pending_asyncs is zero.
*/
- scm_root->pending_asyncs = 0;
- if (scm_root->block_asyncs == 0)
+ scm_i_scm_pthread_mutex_lock (&async_mutex);
+ t->pending_asyncs = 0;
+ if (t->block_asyncs == 0)
{
- SCM asyncs;
- while (!scm_is_null(asyncs = scm_root->active_asyncs))
- {
- scm_root->active_asyncs = SCM_EOL;
- do
- {
- scm_call_0 (SCM_CAR (asyncs));
- asyncs = SCM_CDR (asyncs);
- }
- while (!scm_is_null(asyncs));
- }
- for (asyncs = scm_root->signal_asyncs; !scm_is_null(asyncs);
- asyncs = SCM_CDR (asyncs))
- {
- if (scm_is_true (SCM_CAR (asyncs)))
- {
- SCM proc = SCM_CAR (asyncs);
- SCM_SETCAR (asyncs, SCM_BOOL_F);
- scm_call_0 (proc);
- }
- }
+ asyncs = t->active_asyncs;
+ t->active_asyncs = SCM_EOL;
+ }
+ else
+ asyncs = SCM_EOL;
+ scm_i_pthread_mutex_unlock (&async_mutex);
+
+ while (scm_is_pair (asyncs))
+ {
+ SCM next = SCM_CDR (asyncs);
+ SCM_SETCDR (asyncs, SCM_BOOL_F);
+ scm_call_0 (SCM_CAR (asyncs));
+ asyncs = next;
}
}
@@ -190,24 +190,98 @@ SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
#endif /* SCM_ENABLE_DEPRECATED == 1 */
void
-scm_i_queue_async_cell (SCM c, scm_root_state *root)
+scm_i_queue_async_cell (SCM c, scm_i_thread *t)
{
- SCM p = root->active_asyncs;
+ SCM sleep_object;
+ scm_i_pthread_mutex_t *sleep_mutex;
+ int sleep_fd;
+ SCM p;
+
+ scm_i_scm_pthread_mutex_lock (&async_mutex);
+ p = t->active_asyncs;
SCM_SETCDR (c, SCM_EOL);
- if (p == SCM_EOL)
- root->active_asyncs = c;
+ if (!scm_is_pair (p))
+ t->active_asyncs = c;
else
{
SCM pp;
- while ((pp = SCM_CDR(p)) != SCM_EOL)
+ while (scm_is_pair (pp = SCM_CDR (p)))
{
- if (SCM_CAR (p) == SCM_CAR (c))
- return;
+ if (scm_is_eq (SCM_CAR (p), SCM_CAR (c)))
+ {
+ scm_i_pthread_mutex_unlock (&async_mutex);
+ return;
+ }
p = pp;
}
SCM_SETCDR (p, c);
}
- root->pending_asyncs = 1;
+ t->pending_asyncs = 1;
+ sleep_object = t->sleep_object;
+ sleep_mutex = t->sleep_mutex;
+ sleep_fd = t->sleep_fd;
+ scm_i_pthread_mutex_unlock (&async_mutex);
+
+ if (sleep_mutex)
+ {
+ /* By now, the thread T might be out of its sleep already, or
+ might even be in the next, unrelated sleep. Interrupting it
+ anyway does no harm, however.
+
+ The important thing to prevent here is to signal sleep_cond
+ before T waits on it. This can not happen since T has
+ sleep_mutex locked while setting t->sleep_mutex and will only
+ unlock it again while waiting on sleep_cond.
+ */
+ scm_i_scm_pthread_mutex_lock (sleep_mutex);
+ scm_i_pthread_cond_signal (&t->sleep_cond);
+ scm_i_pthread_mutex_unlock (sleep_mutex);
+ }
+
+ if (sleep_fd >= 0)
+ {
+ char dummy = 0;
+ /* Likewise, T might already been done with sleeping here, but
+ interrupting it once too often does no harm. T might also
+ not yet have started sleeping, but this is no problem either
+ since the data written to a pipe will not be lost, unlike a
+ condition variable signal.
+ */
+ write (sleep_fd, &dummy, 1);
+ }
+
+ /* This is needed to protect sleep_mutex.
+ */
+ scm_remember_upto_here_1 (sleep_object);
+}
+
+int
+scm_i_setup_sleep (scm_i_thread *t,
+ SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex,
+ int sleep_fd)
+{
+ int pending;
+
+ scm_i_scm_pthread_mutex_lock (&async_mutex);
+ pending = t->pending_asyncs;
+ if (!pending)
+ {
+ t->sleep_object = sleep_object;
+ t->sleep_mutex = sleep_mutex;
+ t->sleep_fd = sleep_fd;
+ }
+ scm_i_pthread_mutex_unlock (&async_mutex);
+ return pending;
+}
+
+void
+scm_i_reset_sleep (scm_i_thread *t)
+{
+ scm_i_scm_pthread_mutex_lock (&async_mutex);
+ t->sleep_object = SCM_BOOL_F;
+ t->sleep_mutex = NULL;
+ t->sleep_fd = -1;
+ scm_i_pthread_mutex_unlock (&async_mutex);
}
SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0,
@@ -222,16 +296,24 @@ SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0,
"signal handlers.")
#define FUNC_NAME s_scm_system_async_mark_for_thread
{
+ /* The current thread might not have a handle yet. This can happen
+ when the GC runs immediately before allocating the handle. At
+ the end of that GC, a system async might be marked. Thus, we can
+ not use scm_current_thread here.
+ */
+
+ scm_i_thread *t;
+
if (SCM_UNBNDP (thread))
- thread = scm_current_thread ();
+ t = SCM_I_CURRENT_THREAD;
else
{
SCM_VALIDATE_THREAD (2, thread);
if (scm_c_thread_exited_p (thread))
SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
+ t = SCM_I_THREAD_DATA (thread);
}
- scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F),
- scm_i_thread_root (thread));
+ scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -268,13 +350,15 @@ SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0,
"Unmask signals. The returned value is not specified.")
#define FUNC_NAME s_scm_unmask_signals
{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
scm_c_issue_deprecation_warning
("'unmask-signals' is deprecated. "
"Use 'call-with-blocked-asyncs' instead.");
- if (scm_root->block_asyncs == 0)
+ if (t->block_asyncs == 0)
SCM_MISC_ERROR ("signals already unmasked", SCM_EOL);
- scm_root->block_asyncs = 0;
+ t->block_asyncs = 0;
scm_async_click ();
return SCM_UNSPECIFIED;
}
@@ -286,12 +370,14 @@ SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
"Mask signals. The returned value is not specified.")
#define FUNC_NAME s_scm_mask_signals
{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
scm_c_issue_deprecation_warning
("'mask-signals' is deprecated. Use 'call-with-blocked-asyncs' instead.");
- if (scm_root->block_asyncs > 0)
+ if (t->block_asyncs > 0)
SCM_MISC_ERROR ("signals already masked", SCM_EOL);
- scm_root->block_asyncs = 1;
+ t->block_asyncs = 1;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -299,16 +385,15 @@ SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
#endif /* SCM_ENABLE_DEPRECATED == 1 */
static void
-increase_block (void *unused)
+increase_block (void *data)
{
- scm_root->block_asyncs++;
+ ((scm_i_thread *)data)->block_asyncs++;
}
static void
-decrease_block (void *unused)
+decrease_block (void *data)
{
- scm_root->block_asyncs--;
- if (scm_root->block_asyncs == 0)
+ if (--((scm_i_thread *)data)->block_asyncs == 0)
scm_async_click ();
}
@@ -322,7 +407,8 @@ SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
return scm_internal_dynamic_wind (increase_block,
(scm_t_inner) scm_call_0,
decrease_block,
- (void *)proc, NULL);
+ (void *)proc,
+ SCM_I_CURRENT_THREAD);
}
#undef FUNC_NAME
@@ -332,7 +418,8 @@ scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data)
return (void *)scm_internal_dynamic_wind (increase_block,
(scm_t_inner) proc,
decrease_block,
- data, NULL);
+ data,
+ SCM_I_CURRENT_THREAD);
}
@@ -343,42 +430,46 @@ SCM_DEFINE (scm_call_with_unblocked_asyncs, "call-with-unblocked-asyncs", 1, 0,
"it is running. Return the value returned by @var{proc}.\n")
#define FUNC_NAME s_scm_call_with_unblocked_asyncs
{
- if (scm_root->block_asyncs == 0)
+ if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL);
return scm_internal_dynamic_wind (decrease_block,
(scm_t_inner) scm_call_0,
increase_block,
- (void *)proc, NULL);
+ (void *)proc,
+ SCM_I_CURRENT_THREAD);
}
#undef FUNC_NAME
void *
scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
{
- if (scm_root->block_asyncs == 0)
+ if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
scm_misc_error ("scm_c_call_with_unblocked_asyncs",
"asyncs already unblocked", SCM_EOL);
return (void *)scm_internal_dynamic_wind (decrease_block,
(scm_t_inner) proc,
increase_block,
- data, NULL);
+ data,
+ SCM_I_CURRENT_THREAD);
}
void
scm_frame_block_asyncs ()
{
- scm_frame_rewind_handler (increase_block, NULL, SCM_F_WIND_EXPLICITLY);
- scm_frame_unwind_handler (decrease_block, NULL, SCM_F_WIND_EXPLICITLY);
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ scm_frame_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
+ scm_frame_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
}
void
scm_frame_unblock_asyncs ()
{
- if (scm_root->block_asyncs == 0)
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ if (t->block_asyncs == 0)
scm_misc_error ("scm_with_unblocked_asyncs",
"asyncs already unblocked", SCM_EOL);
- scm_frame_rewind_handler (decrease_block, NULL, SCM_F_WIND_EXPLICITLY);
- scm_frame_unwind_handler (increase_block, NULL, SCM_F_WIND_EXPLICITLY);
+ scm_frame_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
+ scm_frame_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
}
diff --git a/libguile/async.h b/libguile/async.h
index 8bb1ef3e6..fca230382 100644
--- a/libguile/async.h
+++ b/libguile/async.h
@@ -24,6 +24,7 @@
#include "libguile/__scm.h"
#include "libguile/root.h"
+#include "libguile/threads.h"
@@ -37,7 +38,10 @@ SCM_API SCM scm_async (SCM thunk);
SCM_API SCM scm_async_mark (SCM a);
SCM_API SCM scm_system_async_mark (SCM a);
SCM_API SCM scm_system_async_mark_for_thread (SCM a, SCM thread);
-SCM_API void scm_i_queue_async_cell (SCM cell, scm_root_state *);
+SCM_API void scm_i_queue_async_cell (SCM cell, scm_i_thread *);
+SCM_API int scm_i_setup_sleep (scm_i_thread *,
+ SCM obj, scm_i_pthread_mutex_t *m, int fd);
+SCM_API void scm_i_reset_sleep (scm_i_thread *);
SCM_API SCM scm_run_asyncs (SCM list_of_a);
SCM_API SCM scm_noop (SCM args);
SCM_API SCM scm_call_with_blocked_asyncs (SCM proc);
@@ -46,6 +50,7 @@ void *scm_c_call_with_blocked_asyncs (void *(*p) (void *d), void *d);
void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d);
void scm_frame_block_asyncs (void);
void scm_frame_unblock_asyncs (void);
+
SCM_API void scm_init_async (void);
#if (SCM_ENABLE_DEPRECATED == 1)
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 4cdc62656..7877a5356 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -427,7 +427,7 @@ SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0,
{
SCM_VALIDATE_FRAME (1, frame);
if (SCM_UNBNDP (port))
- port = scm_cur_outp;
+ port = scm_current_output_port ();
else
SCM_VALIDATE_OPOUTPORT (2, port);
if (SCM_UNBNDP (indent))
@@ -776,6 +776,7 @@ SCM_DEFINE (scm_backtrace_with_highlights, "backtrace", 0, 1, 0,
"the backtrace.")
#define FUNC_NAME s_scm_backtrace_with_highlights
{
+ SCM port = scm_current_output_port ();
SCM the_last_stack =
scm_fluid_ref (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var));
@@ -784,27 +785,27 @@ SCM_DEFINE (scm_backtrace_with_highlights, "backtrace", 0, 1, 0,
if (scm_is_true (the_last_stack))
{
- scm_newline (scm_cur_outp);
- scm_puts ("Backtrace:\n", scm_cur_outp);
+ scm_newline (port);
+ scm_puts ("Backtrace:\n", port);
scm_display_backtrace_with_highlights (the_last_stack,
- scm_cur_outp,
+ port,
SCM_BOOL_F,
SCM_BOOL_F,
highlights);
- scm_newline (scm_cur_outp);
+ scm_newline (port);
if (scm_is_false (SCM_VARIABLE_REF (scm_has_shown_backtrace_hint_p_var))
&& !SCM_BACKTRACE_P)
{
scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like "
"a backtrace\n"
"automatically if an error occurs in the future.\n",
- scm_cur_outp);
+ port);
SCM_VARIABLE_SET (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
}
}
else
{
- scm_puts ("No backtrace available.\n", scm_cur_outp);
+ scm_puts ("No backtrace available.\n", port);
}
return SCM_UNSPECIFIED;
}
diff --git a/libguile/continuations.c b/libguile/continuations.c
index c9da124d8..60532d4d8 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -29,6 +29,7 @@
#include "libguile/ports.h"
#include "libguile/dynwind.h"
#include "libguile/values.h"
+#include "libguile/eval.h"
#include "libguile/validate.h"
#include "libguile/continuations.h"
@@ -45,6 +46,7 @@ continuation_mark (SCM obj)
{
scm_t_contregs *continuation = SCM_CONTREGS (obj);
+ scm_gc_mark (continuation->root);
scm_gc_mark (continuation->throw_value);
scm_mark_locations (continuation->stack, continuation->num_stack_items);
#ifdef __ia64__
@@ -60,7 +62,7 @@ static size_t
continuation_free (SCM obj)
{
scm_t_contregs *continuation = SCM_CONTREGS (obj);
- /* stack array size is 1 if num_stack_items is 0 (rootcont). */
+ /* stack array size is 1 if num_stack_items is 0. */
size_t extra_items = (continuation->num_stack_items > 0)
? (continuation->num_stack_items - 1)
: 0;
@@ -107,29 +109,29 @@ extern struct rv ia64_getcontext (ucontext_t *) __asm__ ("getcontext");
SCM
scm_make_continuation (int *first)
{
- volatile SCM cont;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ SCM cont;
scm_t_contregs *continuation;
- scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
long stack_size;
SCM_STACKITEM * src;
#ifdef __ia64__
struct rv rv;
#endif /* __ia64__ */
- SCM_ENTER_A_SECTION;
+ SCM_CRITICAL_SECTION_START;
SCM_FLUSH_REGISTER_WINDOWS;
- stack_size = scm_stack_size (rootcont->base);
+ stack_size = scm_stack_size (thread->continuation_base);
continuation = scm_gc_malloc (sizeof (scm_t_contregs)
+ (stack_size - 1) * sizeof (SCM_STACKITEM),
"continuation");
continuation->num_stack_items = stack_size;
- continuation->dynenv = scm_dynwinds;
+ continuation->dynenv = scm_i_dynwinds ();
continuation->throw_value = SCM_EOL;
- continuation->base = src = rootcont->base;
- continuation->seq = rootcont->seq;
- continuation->dframe = scm_last_debug_frame;
+ continuation->root = thread->continuation_root;
+ continuation->dframe = scm_i_last_debug_frame ();
+ src = thread->continuation_base;
SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
- SCM_EXIT_A_SECTION;
+ SCM_CRITICAL_SECTION_END;
#if ! SCM_STACK_GROWS_UP
src -= stack_size;
@@ -237,12 +239,12 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val,
long delta;
copy_stack_data data;
- delta = scm_ilength (scm_dynwinds) - scm_ilength (continuation->dynenv);
+ delta = scm_ilength (scm_i_dynwinds ()) - scm_ilength (continuation->dynenv);
data.continuation = continuation;
data.dst = dst;
scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);
- scm_last_debug_frame = continuation->dframe;
+ scm_i_set_last_debug_frame (continuation->dframe);
continuation->throw_value = val;
#ifdef __ia64__
@@ -262,8 +264,9 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val,
static void
scm_dynthrow (SCM cont, SCM val)
{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_t_contregs *continuation = SCM_CONTREGS (cont);
- SCM_STACKITEM * dst = SCM_BASE (scm_rootcont);
+ SCM_STACKITEM *dst = thread->continuation_base;
SCM_STACKITEM stack_top_element;
#if SCM_STACK_GROWS_UP
@@ -284,15 +287,14 @@ static SCM
continuation_apply (SCM cont, SCM args)
#define FUNC_NAME "continuation_apply"
{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_t_contregs *continuation = SCM_CONTREGS (cont);
- scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
- if (continuation->seq != rootcont->seq
- /* this base comparison isn't needed */
- || continuation->base != rootcont->base)
+ if (continuation->root != thread->continuation_root)
{
- SCM_MISC_ERROR ("continuation from wrong top level: ~S",
- scm_list_1 (cont));
+ SCM_MISC_ERROR
+ ("invoking continuation would cross continuation barrier: ~A",
+ scm_list_1 (cont));
}
scm_dynthrow (cont, scm_values (args));
@@ -300,6 +302,107 @@ continuation_apply (SCM cont, SCM args)
}
#undef FUNC_NAME
+SCM
+scm_i_with_continuation_barrier (scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data)
+{
+ SCM_STACKITEM stack_item;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ SCM old_controot;
+ SCM_STACKITEM *old_contbase;
+ scm_t_debug_frame *old_lastframe;
+ SCM result;
+
+ /* Establish a fresh continuation root.
+ */
+ old_controot = thread->continuation_root;
+ old_contbase = thread->continuation_base;
+ old_lastframe = thread->last_debug_frame;
+ thread->continuation_root = scm_cons (thread->handle, old_controot);
+ thread->continuation_base = &stack_item;
+ thread->last_debug_frame = NULL;
+
+ /* Call FUNC inside a catch all. This is now guaranteed to return
+ directly and exactly once.
+ */
+ result = scm_internal_catch (SCM_BOOL_T,
+ body, body_data,
+ handler, handler_data);
+
+ /* Return to old continuation root.
+ */
+ thread->last_debug_frame = old_lastframe;
+ thread->continuation_base = old_contbase;
+ thread->continuation_root = old_controot;
+
+ return result;
+}
+
+struct c_data {
+ void *(*func) (void *);
+ void *data;
+ void *result;
+};
+
+static SCM
+c_body (void *d)
+{
+ struct c_data *data = (struct c_data *)d;
+ data->result = data->func (data->data);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+c_handler (void *d, SCM tag, SCM args)
+{
+ struct c_data *data = (struct c_data *)d;
+ scm_handle_by_message_noexit (NULL, tag, args);
+ data->result = NULL;
+ return SCM_UNSPECIFIED;
+}
+
+void *
+scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
+{
+ struct c_data c_data;
+ c_data.func = func;
+ c_data.data = data;
+ scm_i_with_continuation_barrier (c_body, &c_data,
+ c_handler, &c_data);
+ return c_data.result;
+}
+
+struct scm_data {
+ SCM proc;
+};
+
+static SCM
+scm_body (void *d)
+{
+ struct scm_data *data = (struct scm_data *)d;
+ return scm_call_0 (data->proc);
+}
+
+static SCM
+scm_handler (void *d, SCM tag, SCM args)
+{
+ scm_handle_by_message_noexit (NULL, tag, args);
+ return SCM_BOOL_F;
+}
+
+SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0,
+ (SCM proc),
+ "Call @var{proc} and return the returned value but do not allow the invocation of continuations that would exit or reenter the dynamic extent of the call to @var{proc}. When a uncaught throw happens during the call to @var{proc}, a message is printed to the current error port and @code{#f} is returned.")
+#define FUNC_NAME s_scm_with_continuation_barrier
+{
+ struct scm_data scm_data;
+ scm_data.proc = proc;
+ return scm_i_with_continuation_barrier (scm_body, &scm_data,
+ scm_handler, &scm_data);
+}
+#undef FUNC_NAME
void
scm_init_continuations ()
diff --git a/libguile/continuations.h b/libguile/continuations.h
index d1298c22d..aa2c66544 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -51,11 +51,10 @@ typedef struct
void *backing_store;
unsigned long backing_store_size;
#endif /* __ia64__ */
- SCM_STACKITEM *base; /* base of the live stack, before it was saved. */
size_t num_stack_items; /* size of the saved stack. */
- unsigned long seq; /* dynamic root identifier. */
+ SCM root; /* continuation root identifier. */
- /* The offset from the live stack location and this copy. This is
+ /* The offset from the live stack location to this copy. This is
used to adjust pointers from within the copied stack to the stack
itself.
@@ -66,7 +65,7 @@ typedef struct
scm_t_ptrdiff offset;
/* The most recently created debug frame on the live stack, before
- it was saved. This need to be adjusted with OFFSET, above.
+ it was saved. This needs to be adjusted with OFFSET, above.
*/
struct scm_t_debug_frame *dframe;
@@ -80,16 +79,24 @@ typedef struct
#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
#define SCM_SET_CONTINUATION_LENGTH(x, n)\
(SCM_CONTREGS (x)->num_stack_items = (n))
-#define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf)
-#define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv)
-#define SCM_THROW_VALUE(x) ((SCM_CONTREGS (x))->throw_value)
-#define SCM_BASE(x) ((SCM_CONTREGS (x))->base)
-#define SCM_SEQ(x) ((SCM_CONTREGS (x))->seq)
-#define SCM_DFRAME(x) ((SCM_CONTREGS (x))->dframe)
+#define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf)
+#define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv)
+#define SCM_THROW_VALUE(x) ((SCM_CONTREGS (x))->throw_value)
+#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)
+#define SCM_DFRAME(x) ((SCM_CONTREGS (x))->dframe)
SCM_API SCM scm_make_continuation (int *first);
+
+SCM_API void *scm_c_with_continuation_barrier (void *(*func)(void*), void *);
+SCM_API SCM scm_with_continuation_barrier (SCM proc);
+
+SCM_API SCM scm_i_with_continuation_barrier (scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data);
+
SCM_API void scm_init_continuations (void);
#endif /* SCM_CONTINUATIONS_H */
diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c
deleted file mode 100644
index e69de29bb..000000000
--- a/libguile/coop-threads.c
+++ /dev/null
diff --git a/libguile/debug.c b/libguile/debug.c
index ca9d08520..42790809e 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -54,7 +54,7 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
#define FUNC_NAME s_scm_debug_options
{
SCM ans;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
ans = scm_options (setting, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
{
@@ -64,7 +64,7 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
SCM_RESET_DEBUG_MODE;
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
scm_debug_eframe_size = 2 * SCM_N_FRAMES;
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return ans;
}
#undef FUNC_NAME
@@ -143,10 +143,10 @@ scm_make_memoized (SCM exp, SCM env)
{
/* *fixme* Check that env is a valid environment. */
register SCM z, ans;
- SCM_ENTER_A_SECTION;
+ SCM_CRITICAL_SECTION_START;
SCM_NEWSMOB (z, SCM_UNPACK (exp), SCM_UNPACK (env));
SCM_NEWSMOB (ans, scm_tc16_memoized, SCM_UNPACK (z));
- SCM_EXIT_A_SECTION;
+ SCM_CRITICAL_SECTION_END;
return ans;
}
@@ -446,13 +446,13 @@ scm_start_stack (SCM id, SCM exp, SCM env)
SCM answer;
scm_t_debug_frame vframe;
scm_t_debug_info vframe_vect_body;
- vframe.prev = scm_last_debug_frame;
+ vframe.prev = scm_i_last_debug_frame ();
vframe.status = SCM_VOIDFRAME;
vframe.vect = &vframe_vect_body;
vframe.vect[0].id = id;
- scm_last_debug_frame = &vframe;
+ scm_i_set_last_debug_frame (&vframe);
answer = scm_i_eval (exp, env);
- scm_last_debug_frame = vframe.prev;
+ scm_i_set_last_debug_frame (vframe.prev);
return answer;
}
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index d8c2f1f9f..685fa2cf1 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -43,6 +43,7 @@
#include "libguile/smob.h"
#include "libguile/alist.h"
#include "libguile/keywords.h"
+#include "libguile/feature.h"
#include <stdio.h>
#include <string.h>
@@ -199,7 +200,7 @@ SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0,
{
struct moddata *md1, *md2;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
for (md1 = registered_mods; md1; md1 = md2)
{
@@ -208,7 +209,7 @@ SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0,
}
registered_mods = NULL;
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -687,7 +688,7 @@ scm_sym2ovcell_soft (SCM sym, SCM obarray)
scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. "
"Use hashtables instead.");
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
for (lsym = SCM_VECTOR_REF (obarray, hash);
SCM_NIMP (lsym);
lsym = SCM_CDR (lsym))
@@ -695,11 +696,11 @@ scm_sym2ovcell_soft (SCM sym, SCM obarray)
z = SCM_CAR (lsym);
if (scm_is_eq (SCM_CAR (z), sym))
{
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return z;
}
}
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_BOOL_F;
}
@@ -872,7 +873,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0,
SCM_VALIDATE_VECTOR (1,o);
hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
/* If the symbol is already interned, simply return. */
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
{
SCM lsym;
SCM sym;
@@ -883,7 +884,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0,
sym = SCM_CAR (lsym);
if (scm_is_eq (SCM_CAR (sym), s))
{
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
}
}
@@ -891,7 +892,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0,
scm_acons (s, SCM_UNDEFINED,
SCM_VECTOR_REF (o, hval)));
}
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -913,7 +914,7 @@ SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
return SCM_BOOL_F;
SCM_VALIDATE_VECTOR (1,o);
hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
{
SCM lsym_follow;
SCM lsym;
@@ -930,12 +931,12 @@ SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
SCM_VECTOR_SET (o, hval, lsym);
else
SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_BOOL_T;
}
}
}
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -1357,6 +1358,86 @@ scm_i_array_dims (SCM a)
return SCM_I_ARRAY_DIMS (a);
}
+SCM
+scm_i_cur_inp (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_cur_inp is deprecated. Use scm_current_input_port instead.");
+ return scm_current_input_port ();
+}
+
+SCM
+scm_i_cur_outp (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_cur_outp is deprecated. Use scm_current_output_port instead.");
+ return scm_current_output_port ();
+}
+
+SCM
+scm_i_cur_errp (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_cur_errp is deprecated. Use scm_current_error_port instead.");
+ return scm_current_error_port ();
+}
+
+SCM
+scm_i_cur_loadp (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_cur_loadp is deprecated. Use scm_current_load_port instead.");
+ return scm_current_load_port ();
+}
+
+SCM
+scm_i_progargs (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_progargs is deprecated. Use scm_program_arguments instead.");
+ return scm_program_arguments ();
+}
+
+SCM
+scm_i_deprecated_dynwinds (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_dynwinds is deprecated. Do not use it.");
+ return scm_i_dynwinds ();
+}
+
+scm_t_debug_frame *
+scm_i_deprecated_last_debug_frame (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_last_debug_frame is deprecated. Do not use it.");
+ return scm_i_last_debug_frame ();
+}
+
+SCM_STACKITEM *
+scm_i_stack_base (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_stack_base is deprecated. Do not use it.");
+ return SCM_I_CURRENT_THREAD->base;
+}
+
+int
+scm_i_fluidp (SCM x)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_FLUIDP is deprecated. Use scm_is_fluid instead.");
+ return scm_is_fluid (x);
+}
+
+void
+scm_i_defer_ints_etc ()
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_CRITICAL_SECTION_START etc are deprecated. "
+ "Use a mutex instead if appropriate.");
+}
+
void
scm_i_init_deprecated ()
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index f5cd5f3bd..51edc7c10 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -511,6 +511,62 @@ SCM_API scm_t_array_dim *scm_i_array_dims (SCM a);
#define SCM_ARRAY_BASE(a) scm_i_array_base(a)
#define SCM_ARRAY_DIMS(a) scm_i_array_dims(a)
+/* Deprecated because they should not be lvalues and we want people to
+ use the official interfaces.
+ */
+
+#define scm_cur_inp scm_i_cur_inp ()
+#define scm_cur_outp scm_i_cur_outp ()
+#define scm_cur_errp scm_i_cur_errp ()
+#define scm_cur_loadp scm_i_cur_loadp ()
+#define scm_progargs scm_i_progargs ()
+#define scm_dynwinds scm_i_deprecated_dynwinds ()
+#define scm_last_debug_frame scm_i_deprecated_last_debug_frame ()
+#define scm_stack_base scm_i_stack_base ()
+
+SCM_API SCM scm_i_cur_inp (void);
+SCM_API SCM scm_i_cur_outp (void);
+SCM_API SCM scm_i_cur_errp (void);
+SCM_API SCM scm_i_cur_loadp (void);
+SCM_API SCM scm_i_progargs (void);
+SCM_API SCM scm_i_deprecated_dynwinds (void);
+SCM_API scm_t_debug_frame *scm_i_deprecated_last_debug_frame (void);
+SCM_API SCM_STACKITEM *scm_i_stack_base (void);
+
+/* Deprecated because it evaluates its argument twice.
+ */
+#define SCM_FLUIDP(x) scm_i_fluidp (x)
+SCM_API int scm_i_fluidp (SCM x);
+
+/* In the old days, SCM_CRITICAL_SECTION_START stopped signal handlers from running,
+ since in those days the handler directly ran scheme code, and that had to
+ be avoided when the heap was not in a consistent state etc. And since
+ the scheme code could do a stack swapping new continuation etc, signals
+ had to be deferred around various C library functions which were not safe
+ or not known to be safe to swap away, which was a lot of stuff.
+
+ These days signals are implemented with asyncs and don't directly run
+ scheme code in the handler, but hold it until an SCM_TICK etc where it
+ will be safe. This means interrupt protection is not needed and
+ SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END is something of an anachronism.
+
+ What past SCM_CRITICAL_SECTION_START usage also did though was indicate code that was
+ not reentrant, ie. could not be reentered by signal handler code. The
+ present definitions are a mutex lock, affording that reentrancy
+ protection against the new guile 1.8 free-running posix threads.
+
+ One big problem with the present defintions though is that code which
+ throws an error from within a DEFER/ALLOW region will leave the
+ defer_mutex locked and hence hang other threads that attempt to enter a
+ similar DEFER/ALLOW region.
+*/
+
+SCM_API void scm_i_defer_ints_etc (void);
+#define SCM_DEFER_INTS scm_i_defer_ints_etc ()
+#define SCM_ALLOW_INTS scm_i_defer_ints_etc ()
+#define SCM_REDEFER_INTS scm_i_defer_ints_etc ()
+#define SCM_REALLOW_INTS scm_i_defer_ints_etc ()
+
void scm_i_init_deprecated (void);
#endif
diff --git a/libguile/discouraged.h b/libguile/discouraged.h
index b1fa79ecd..98435e52e 100644
--- a/libguile/discouraged.h
+++ b/libguile/discouraged.h
@@ -168,6 +168,13 @@ SCM_API SCM scm_keyword_dash_symbol (SCM keyword);
SCM_API SCM scm_c_make_keyword (const char *s);
+/* Discouraged because the 'internal' and 'thread' moniker is
+ confusing.
+ */
+
+#define scm_internal_select scm_std_select
+#define scm_thread_sleep scm_std_sleep
+#define scm_thread_usleep scm_std_usleep
void scm_i_init_discouraged (void);
diff --git a/libguile/dynl.c b/libguile/dynl.c
index ab0d011fe..c22c592c4 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -59,10 +59,10 @@ maybe_drag_in_eprintf ()
From the libtool manual: "Note that libltdl is not threadsafe,
i.e. a multithreaded application has to use a mutex for libltdl.".
- Guile does not currently support pre-emptive threads, so there is
- no mutex. Previously SCM_DEFER_INTS and SCM_ALLOW_INTS were used:
- they are mentioned here in case somebody is grepping for thread
- problems ;)
+ Guile does not currently support pre-emptive threads, so there is no
+ mutex. Previously SCM_CRITICAL_SECTION_START and
+ SCM_CRITICAL_SECTION_END were used: they are mentioned here in case
+ somebody is grepping for thread problems ;)
*/
static void *
diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index 01a02254f..d3b3b07f3 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -97,14 +97,15 @@ SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_dynamic_wind
{
- SCM ans;
+ SCM ans, old_winds;
SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
out_guard,
SCM_ARG3, FUNC_NAME);
scm_call_0 (in_guard);
- scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds);
+ old_winds = scm_i_dynwinds ();
+ scm_i_set_dynwinds (scm_acons (in_guard, out_guard, old_winds));
ans = scm_call_0 (thunk);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
+ scm_i_set_dynwinds (old_winds);
scm_call_0 (out_guard);
return ans;
}
@@ -154,20 +155,25 @@ scm_frame_begin (scm_t_frame_flags flags)
SCM_NEWSMOB (f, tc16_frame, 0);
if (flags & SCM_F_FRAME_REWINDABLE)
SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE);
- scm_dynwinds = scm_cons (f, scm_dynwinds);
+ scm_i_set_dynwinds (scm_cons (f, scm_i_dynwinds ()));
}
void
scm_frame_end (void)
{
+ SCM winds;
+
/* Unwind upto and including the next frame entry. We can only
encounter #<winder> entries on the way.
*/
- while (scm_is_pair (scm_dynwinds))
+ winds = scm_i_dynwinds ();
+ while (scm_is_pair (winds))
{
- SCM entry = SCM_CAR (scm_dynwinds);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
+ SCM entry = SCM_CAR (winds);
+ winds = SCM_CDR (winds);
+
+ scm_i_set_dynwinds (winds);
if (FRAME_P (entry))
return;
@@ -196,7 +202,7 @@ scm_frame_unwind_handler (void (*proc) (void *), void *data,
SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
if (flags & SCM_F_WIND_EXPLICITLY)
SCM_SET_SMOB_FLAGS (w, WINDER_F_EXPLICIT);
- scm_dynwinds = scm_cons (w, scm_dynwinds);
+ scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
}
void
@@ -206,7 +212,7 @@ scm_frame_rewind_handler (void (*proc) (void *), void *data,
SCM w;
SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND);
- scm_dynwinds = scm_cons (w, scm_dynwinds);
+ scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
if (flags & SCM_F_WIND_EXPLICITLY)
proc (data);
}
@@ -219,7 +225,7 @@ scm_frame_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
SCM_SET_SMOB_FLAGS (w, fl | WINDER_F_MARK);
- scm_dynwinds = scm_cons (w, scm_dynwinds);
+ scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
}
void
@@ -229,7 +235,7 @@ scm_frame_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
SCM w;
SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND | WINDER_F_MARK);
- scm_dynwinds = scm_cons (w, scm_dynwinds);
+ scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
if (flags & SCM_F_WIND_EXPLICITLY)
proc (data);
}
@@ -248,7 +254,7 @@ SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
"argument thunks when entering/exiting its scope.")
#define FUNC_NAME s_scm_wind_chain
{
- return scm_dynwinds;
+ return scm_i_dynwinds ();
}
#undef FUNC_NAME
#endif
@@ -277,7 +283,7 @@ void
scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
{
tail:
- if (scm_is_eq (to, scm_dynwinds))
+ if (scm_is_eq (to, scm_i_dynwinds ()))
{
if (turn_func)
turn_func (data);
@@ -318,15 +324,17 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
}
}
- scm_dynwinds = to;
+ scm_i_set_dynwinds (to);
}
else
{
+ SCM wind;
SCM wind_elt;
SCM wind_key;
- wind_elt = SCM_CAR (scm_dynwinds);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
+ wind = scm_i_dynwinds ();
+ wind_elt = SCM_CAR (wind);
+ scm_i_set_dynwinds (SCM_CDR (wind));
if (FRAME_P (wind_elt))
{
diff --git a/libguile/error.c b/libguile/error.c
index 28b5bc150..dc7e25ac1 100644
--- a/libguile/error.c
+++ b/libguile/error.c
@@ -131,10 +131,7 @@ SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0,
{
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_i_frame_pthread_mutex_lock (&scm_i_misc_mutex);
ret = scm_from_locale_string (SCM_I_STRERROR (scm_to_int (err)));
diff --git a/libguile/eval.c b/libguile/eval.c
index 8c3ed5617..b22f35e38 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -80,6 +80,7 @@ char *alloca ();
#include "libguile/srcprop.h"
#include "libguile/stackchk.h"
#include "libguile/strings.h"
+#include "libguile/threads.h"
#include "libguile/throw.h"
#include "libguile/validate.h"
#include "libguile/values.h"
@@ -877,10 +878,10 @@ macroexp (SCM x, SCM env)
if (scm_ilength (res) <= 0)
res = scm_list_2 (SCM_IM_BEGIN, res);
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
SCM_SETCAR (x, SCM_CAR (res));
SCM_SETCDR (x, SCM_CDR (res));
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
goto macro_tail;
}
@@ -2641,7 +2642,7 @@ static SCM deval (SCM x, SCM env);
? SCM_CAR (x) \
: *scm_lookupcar ((x), (env), 1)))))
-SCM_REC_MUTEX (source_mutex);
+scm_i_pthread_mutex_t source_mutex = SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER;
/* Lookup a given local variable in an environment. The local variable is
@@ -2936,11 +2937,11 @@ scm_eval_body (SCM code, SCM env)
{
if (SCM_ISYMP (SCM_CAR (code)))
{
- scm_rec_mutex_lock (&source_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&source_mutex);
goto again;
}
}
@@ -3084,13 +3085,13 @@ SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
#define FUNC_NAME s_scm_eval_options_interface
{
SCM ans;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
ans = scm_options (setting,
scm_eval_opts,
SCM_N_EVAL_OPTIONS,
FUNC_NAME);
scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return ans;
}
#undef FUNC_NAME
@@ -3102,13 +3103,13 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
#define FUNC_NAME s_scm_evaluator_traps
{
SCM ans;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
ans = scm_options (setting,
scm_evaluator_trap_table,
SCM_N_EVALUATOR_TRAPS,
FUNC_NAME);
SCM_RESET_DEBUG_MODE;
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return ans;
}
#undef FUNC_NAME
@@ -3185,7 +3186,7 @@ CEVAL (SCM x, SCM env)
#ifdef DEVAL
scm_t_debug_frame debug;
scm_t_debug_info *debug_info_end;
- debug.prev = scm_last_debug_frame;
+ debug.prev = scm_i_last_debug_frame ();
debug.status = 0;
/*
* The debug.vect contains twice as much scm_t_debug_info frames as the
@@ -3197,7 +3198,7 @@ CEVAL (SCM x, SCM env)
* sizeof (scm_t_debug_info));
debug.info = debug.vect;
debug_info_end = debug.vect + scm_debug_eframe_size;
- scm_last_debug_frame = &debug;
+ scm_i_set_last_debug_frame (&debug);
#endif
#ifdef EVAL_STACK_CHECKING
if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
@@ -3326,11 +3327,11 @@ dispatch:
{
if (SCM_ISYMP (form))
{
- scm_rec_mutex_lock (&source_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&source_mutex);
goto nontoplevel_begin;
}
else
@@ -3903,7 +3904,7 @@ dispatch:
}
scm_swap_bindings (vars, vals);
- scm_dynwinds = scm_acons (vars, vals, scm_dynwinds);
+ scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ()));
/* Ignore all but the last evaluation result. */
for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x))
@@ -3913,7 +3914,7 @@ dispatch:
}
proc = EVALCAR (x, env);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
scm_swap_bindings (vars, vals);
RETURN (proc);
@@ -3997,10 +3998,10 @@ dispatch:
#ifdef DEVAL
if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
{
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
SCM_SETCAR (x, SCM_CAR (arg1));
SCM_SETCDR (x, SCM_CDR (arg1));
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
goto dispatch;
}
/* Prevent memoizing of debug info expression. */
@@ -4008,10 +4009,10 @@ dispatch:
SCM_CAR (x),
SCM_CDR (x));
#endif
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
SCM_SETCAR (x, SCM_CAR (arg1));
SCM_SETCDR (x, SCM_CDR (arg1));
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto loop;
#if SCM_ENABLE_DEPRECATED == 1
@@ -4578,7 +4579,7 @@ exit:
SCM_TRAPS_P = 1;
}
ret:
- scm_last_debug_frame = debug.prev;
+ scm_i_set_last_debug_frame (debug.prev);
return proc;
#endif
}
@@ -4734,12 +4735,12 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args)
#ifdef DEVAL
scm_t_debug_frame debug;
scm_t_debug_info debug_vect_body;
- debug.prev = scm_last_debug_frame;
+ debug.prev = scm_i_last_debug_frame ();
debug.status = SCM_APPLYFRAME;
debug.vect = &debug_vect_body;
debug.vect[0].a.proc = proc;
debug.vect[0].a.args = SCM_EOL;
- scm_last_debug_frame = &debug;
+ scm_i_set_last_debug_frame (&debug);
#else
if (scm_debug_mode_p)
return scm_dapply (proc, arg1, args);
@@ -4929,11 +4930,11 @@ tail:
{
if (SCM_ISYMP (SCM_CAR (proc)))
{
- scm_rec_mutex_lock (&source_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&source_mutex);
goto again;
}
else
@@ -5038,7 +5039,7 @@ exit:
SCM_TRAPS_P = 1;
}
ret:
- scm_last_debug_frame = debug.prev;
+ scm_i_set_last_debug_frame (debug.prev);
return proc;
#endif
}
@@ -5560,13 +5561,19 @@ scm_makprom (SCM code)
{
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;
}
@@ -5590,7 +5597,7 @@ SCM_DEFINE (scm_force, "force", 1, 0, 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));
@@ -5600,7 +5607,7 @@ SCM_DEFINE (scm_force, "force", 1, 0, 0,
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
@@ -5813,13 +5820,15 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0,
environment and calling scm_i_eval. Thus, changes to the
top-level module are tracked normally.
- - scm_eval (exp, mod)
+ - scm_eval (exp, mod_or_state)
- evaluates EXP while MOD is the current module. This is done by
- setting the current module to MOD, invoking scm_primitive_eval on
- EXP, and then restoring the current module to the value it had
- previously. That is, while EXP is evaluated, changes to the
- current module are tracked, but these changes do not persist when
+ evaluates EXP while MOD_OR_STATE is the current module or current
+ dynamic state (as appropriate). This is done by setting the
+ current module (or dynamic state) to MOD_OR_STATE, invoking
+ scm_primitive_eval on EXP, and then restoring the current module
+ (or dynamic state) to the value it had previously. That is,
+ while EXP is evaluated, changes to the current module (or dynamic
+ state) are tracked, but these changes do not persist when
scm_eval returns.
For each level of evals, there are two variants, distinguished by a
@@ -5882,67 +5891,47 @@ SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
* system, where we would like to make the choice of evaluation
* environment explicit. */
-static void
-change_environment (void *data)
-{
- SCM pair = SCM_PACK (data);
- SCM new_module = SCM_CAR (pair);
- SCM old_module = scm_current_module ();
- SCM_SETCDR (pair, old_module);
- scm_set_current_module (new_module);
-}
-
-static void
-restore_environment (void *data)
-{
- SCM pair = SCM_PACK (data);
- SCM old_module = SCM_CDR (pair);
- SCM new_module = scm_current_module ();
- SCM_SETCAR (pair, new_module);
- scm_set_current_module (old_module);
-}
-
-static SCM
-inner_eval_x (void *data)
-{
- return scm_primitive_eval_x (SCM_PACK(data));
-}
-
SCM
-scm_eval_x (SCM exp, SCM module)
-#define FUNC_NAME "eval!"
+scm_eval_x (SCM exp, SCM module_or_state)
{
- SCM_VALIDATE_MODULE (2, module);
+ SCM res;
- return scm_internal_dynamic_wind
- (change_environment, inner_eval_x, restore_environment,
- (void *) SCM_UNPACK (exp),
- (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
-}
-#undef FUNC_NAME
+ scm_frame_begin (SCM_F_FRAME_REWINDABLE);
+ if (scm_is_dynamic_state (module_or_state))
+ scm_frame_current_dynamic_state (module_or_state);
+ else
+ scm_frame_current_module (module_or_state);
-static SCM
-inner_eval (void *data)
-{
- return scm_primitive_eval (SCM_PACK(data));
+ res = scm_primitive_eval_x (exp);
+
+ scm_frame_end ();
+ return res;
}
SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
- (SCM exp, SCM module),
+ (SCM exp, SCM module_or_state),
"Evaluate @var{exp}, a list representing a Scheme expression,\n"
- "in the top-level environment specified by @var{module}.\n"
+ "in the top-level environment specified by\n"
+ "@var{module_or_state}.\n"
"While @var{exp} is evaluated (using @code{primitive-eval}),\n"
- "@var{module} is made the current module. The current module\n"
- "is reset to its previous value when @var{eval} returns.\n"
+ "@var{module_or_state} is made the current module when\n"
+ "it is a module, or the current dynamic state when it is\n"
+ "a dynamic state."
"Example: (eval '(+ 1 2) (interaction-environment))")
#define FUNC_NAME s_scm_eval
{
- SCM_VALIDATE_MODULE (2, module);
+ SCM res;
+
+ scm_frame_begin (SCM_F_FRAME_REWINDABLE);
+ if (scm_is_dynamic_state (module_or_state))
+ scm_frame_current_dynamic_state (module_or_state);
+ else
+ scm_frame_current_module (module_or_state);
+
+ res = scm_primitive_eval (exp);
- return scm_internal_dynamic_wind
- (change_environment, inner_eval, restore_environment,
- (void *) SCM_UNPACK (exp),
- (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
+ scm_frame_end ();
+ return res;
}
#undef FUNC_NAME
@@ -6004,7 +5993,7 @@ scm_init_eval ()
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);
diff --git a/libguile/eval.h b/libguile/eval.h
index 1d10e08b3..f1b94a05f 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -71,8 +71,7 @@ SCM_API SCM scm_eval_options_interface (SCM setting);
(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
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 0d7cb25dc..7673c16f0 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1259,9 +1259,9 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
}
{
- int rv = scm_internal_select (max_fd + 1,
- &read_set, &write_set, &except_set,
- time_ptr);
+ int rv = scm_std_select (max_fd + 1,
+ &read_set, &write_set, &except_set,
+ time_ptr);
if (rv < 0)
SCM_SYSERROR;
}
diff --git a/libguile/fluids.c b/libguile/fluids.c
index acdec1103..ab27029f8 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -15,7 +15,8 @@
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
-
+#include <stdio.h>
+#include <string.h>
#include "libguile/_scm.h"
#include "libguile/print.h"
@@ -27,84 +28,247 @@
#include "libguile/ports.h"
#include "libguile/deprecation.h"
#include "libguile/lang.h"
-
-#define INITIAL_FLUIDS 10
#include "libguile/validate.h"
-static volatile long n_fluids;
-scm_t_bits scm_tc16_fluid;
+#define FLUID_GROW 20
+
+/* A lot of the complexity below stems from the desire to reuse fluid
+ slots. Normally, fluids should be pretty global and long-lived
+ things, so that reusing their slots should not be overly critical,
+ but it is the right thing to do nevertheless. The code therefore
+ puts the burdon on allocating and collection fluids and keeps
+ accessing fluids lock free. This is achieved by manipulating the
+ global state of the fluid machinery mostly in single threaded
+ sections.
+
+ Reusing a fluid slot means that it must be reset to #f in all
+ dynamic states. We do this by maintaining a weak list of all
+ dynamic states, which is used after a GC to do the resetting.
+
+ Also, the fluid vectors in the dynamic states need to grow from
+ time to time when more fluids are created. We do this in a single
+ threaded section so that threads do not need to lock when accessing
+ a fluid in the normal way.
+*/
-SCM
-scm_i_make_initial_fluids ()
+static scm_i_pthread_mutex_t fluid_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+/* Protected by fluid_admin_mutex, but also accessed during GC. See
+ next_fluid_num for a discussion of this.
+ */
+static size_t allocated_fluids_len = 0;
+static size_t allocated_fluids_num = 0;
+static char *allocated_fluids = NULL;
+
+static scm_t_bits tc16_fluid;
+
+#define IS_FLUID(x) SCM_SMOB_PREDICATE(tc16_fluid, (x))
+#define FLUID_NUM(x) ((size_t)SCM_SMOB_DATA(x))
+#define FLUID_NEXT(x) SCM_SMOB_OBJECT_2(x)
+#define SET_FLUID_NEXT(x,y) SCM_SET_SMOB_OBJECT_2((x), (y))
+
+static scm_t_bits tc16_dynamic_state;
+
+#define IS_DYNAMIC_STATE(x) SCM_SMOB_PREDICATE(tc16_dynamic_state, (x))
+#define DYNAMIC_STATE_FLUIDS(x) SCM_SMOB_OBJECT(x)
+#define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_SMOB_OBJECT((x), (y))
+#define DYNAMIC_STATE_NEXT(x) SCM_SMOB_OBJECT_2(x)
+#define SET_DYNAMIC_STATE_NEXT(x, y) SCM_SET_SMOB_OBJECT_2((x), (y))
+
+/* Weak lists of all dynamic states and all fluids.
+ */
+static SCM all_dynamic_states = SCM_EOL;
+static SCM all_fluids = SCM_EOL;
+
+/* Make sure that the dynamic state STATE has the right size. This
+ must be called while being single threaded and while
+ fluid_admin_mutex is held.
+*/
+static void
+ensure_state_size (SCM state)
{
- return scm_c_make_vector (INITIAL_FLUIDS, SCM_BOOL_F);
+ SCM fluids = DYNAMIC_STATE_FLUIDS (state);
+ size_t len = SCM_SIMPLE_VECTOR_LENGTH (fluids), i;
+
+ if (len != allocated_fluids_len)
+ {
+ SCM new_fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F);
+ for (i = 0; i < len; i++)
+ SCM_SIMPLE_VECTOR_SET (new_fluids, i,
+ SCM_SIMPLE_VECTOR_REF (fluids, i));
+ SET_DYNAMIC_STATE_FLUIDS (state, new_fluids);
+ }
}
+/* Make sure that all states have the right size. This must be called
+ while fluid_admin_mutex is held.
+*/
static void
-grow_fluids (scm_root_state *root_state, int new_length)
+ensure_all_state_sizes ()
+{
+ SCM state;
+
+ scm_frame_begin (0);
+ scm_i_frame_single_threaded ();
+
+ scm_gc ();
+ for (state = all_dynamic_states; !scm_is_null (state);
+ state = DYNAMIC_STATE_NEXT (state))
+ ensure_state_size (state);
+
+ scm_frame_end ();
+}
+
+/* This is called during GC, that is, while being single threaded.
+ See next_fluid_num for a discussion why it is safe to access
+ allocated_fluids here.
+ */
+static void *
+scan_dynamic_states_and_fluids (void *dummy1 SCM_UNUSED,
+ void *dummy2 SCM_UNUSED,
+ void *dummy3 SCM_UNUSED)
{
- SCM old_fluids, new_fluids;
- long old_length, i;
+ SCM *statep, *fluidp;
- old_fluids = root_state->fluids;
- old_length = SCM_SIMPLE_VECTOR_LENGTH (old_fluids);
- new_fluids = scm_c_make_vector (new_length, SCM_BOOL_F);
- i = 0;
- while (i < old_length)
+ /* Scan all fluids and deallocate the unmarked ones.
+ */
+ fluidp = &all_fluids;
+ while (!scm_is_null (*fluidp))
{
- SCM_SIMPLE_VECTOR_SET (new_fluids, i,
- SCM_SIMPLE_VECTOR_REF (old_fluids, i));
- i++;
+ if (!SCM_GC_MARK_P (*fluidp))
+ {
+ allocated_fluids_num -= 1;
+ allocated_fluids[FLUID_NUM (*fluidp)] = 0;
+ *fluidp = FLUID_NEXT (*fluidp);
+ }
+ else
+ fluidp = &FLUID_NEXT (*fluidp);
}
- while (i < new_length)
+
+ /* Scan all dynamic states and remove the unmarked ones. The live
+ ones are updated for unallocated fluids.
+ */
+ statep = &all_dynamic_states;
+ while (!scm_is_null (*statep))
{
- SCM_SIMPLE_VECTOR_SET (new_fluids, i, SCM_BOOL_F);
- i++;
+ if (!SCM_GC_MARK_P (*statep))
+ *statep = DYNAMIC_STATE_NEXT (*statep);
+ else
+ {
+ SCM fluids = DYNAMIC_STATE_FLUIDS (*statep);
+ size_t len, i;
+
+ len = SCM_SIMPLE_VECTOR_LENGTH (fluids);
+ for (i = 0; i < len && i < allocated_fluids_len; i++)
+ if (allocated_fluids[i] == 0)
+ SCM_SIMPLE_VECTOR_SET (fluids, i, SCM_BOOL_F);
+
+ statep = &DYNAMIC_STATE_NEXT (*statep);
+ }
}
- root_state->fluids = new_fluids;
+ return NULL;
}
-void
-scm_i_copy_fluids (scm_root_state *root_state)
+static size_t
+fluid_free (SCM fluid)
{
- grow_fluids (root_state, SCM_SIMPLE_VECTOR_LENGTH (root_state->fluids));
+ /* The real work is done in scan_dynamic_states_and_fluids. We can
+ not touch allocated_fluids etc here since a smob free routine can
+ be run at any time, in any thread.
+ */
+ return 0;
}
static int
fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
scm_puts ("#<fluid ", port);
- scm_intprint ((int) SCM_FLUID_NUM (exp), 10, port);
+ scm_intprint ((int) FLUID_NUM (exp), 10, port);
scm_putc ('>', port);
return 1;
}
-static long
+static size_t
next_fluid_num ()
{
- long n;
- SCM_CRITICAL_SECTION_START;
- n = n_fluids++;
- SCM_CRITICAL_SECTION_END;
+ size_t n;
+
+ scm_frame_begin (0);
+ scm_i_frame_pthread_mutex_lock (&fluid_admin_mutex);
+
+ if (allocated_fluids_num == allocated_fluids_len)
+ {
+ /* All fluid numbers are in use. Run a GC to try to free some
+ up.
+ */
+ scm_gc ();
+ }
+
+ if (allocated_fluids_num < allocated_fluids_len)
+ {
+ for (n = 0; n < allocated_fluids_len; n++)
+ if (allocated_fluids[n] == 0)
+ break;
+ }
+ else
+ {
+ /* During the following call, the GC might run and elements of
+ allocated_fluids might bet set to zero. Also,
+ allocated_fluids and allocated_fluids_len are used to scan
+ all dynamic states during GC. Thus we need to make sure that
+ no GC can run while updating these two variables.
+ */
+
+ char *new_allocated_fluids =
+ scm_malloc (allocated_fluids_len + FLUID_GROW);
+
+ /* Copy over old values and initialize rest. GC can not run
+ during these two operations since there is no safe point in
+ them.
+ */
+ memcpy (new_allocated_fluids, allocated_fluids, allocated_fluids_len);
+ memset (new_allocated_fluids + allocated_fluids_len, 0, FLUID_GROW);
+ n = allocated_fluids_len;
+ allocated_fluids = new_allocated_fluids;
+ allocated_fluids_len += FLUID_GROW;
+
+ /* Now allocated_fluids and allocated_fluids_len are valid again
+ and we can allow GCs to occur.
+ */
+ ensure_all_state_sizes ();
+ }
+
+ allocated_fluids_num += 1;
+ allocated_fluids[n] = 1;
+
+ scm_frame_end ();
return n;
}
SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
(),
"Return a newly created fluid.\n"
- "Fluids are objects of a certain type (a smob) that can hold one SCM\n"
- "value per dynamic root. That is, modifications to this value are\n"
- "only visible to code that executes within the same dynamic root as\n"
- "the modifying code. When a new dynamic root is constructed, it\n"
- "inherits the values from its parent. Because each thread executes\n"
- "in its own dynamic root, you can use fluids for thread local storage.")
+ "Fluids are objects that can hold one\n"
+ "value per dynamic state. That is, modifications to this value are\n"
+ "only visible to code that executes with the same dynamic state as\n"
+ "the modifying code. When a new dynamic state is constructed, it\n"
+ "inherits the values from its parent. Because each thread normally executes\n"
+ "with its own dynamic state, you can use fluids for thread local storage.")
#define FUNC_NAME s_scm_make_fluid
{
- long n;
+ SCM fluid;
- n = next_fluid_num ();
- SCM_RETURN_NEWSMOB (scm_tc16_fluid, n);
+ SCM_NEWSMOB2 (fluid, tc16_fluid,
+ (scm_t_bits) next_fluid_num (), SCM_UNPACK (SCM_EOL));
+
+ /* The GC must not run until the fluid is properly entered into the
+ list.
+ */
+ SET_FLUID_NEXT (fluid, all_fluids);
+ all_fluids = fluid;
+
+ return fluid;
}
#undef FUNC_NAME
@@ -114,10 +278,22 @@ SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0,
"@code{#f}.")
#define FUNC_NAME s_scm_fluid_p
{
- return scm_from_bool(SCM_FLUIDP (obj));
+ return scm_from_bool (IS_FLUID (obj));
}
#undef FUNC_NAME
+int
+scm_is_fluid (SCM obj)
+{
+ return IS_FLUID (obj);
+}
+
+size_t
+scm_i_fluid_num (SCM fluid)
+{
+ return FLUID_NUM (fluid);
+}
+
SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
(SCM fluid),
"Return the value associated with @var{fluid} in the current\n"
@@ -125,34 +301,40 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
"@code{#f}.")
#define FUNC_NAME s_scm_fluid_ref
{
- unsigned long int n;
+ SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
SCM_VALIDATE_FLUID (1, fluid);
- n = SCM_FLUID_NUM (fluid);
-
- if (SCM_SIMPLE_VECTOR_LENGTH (scm_root->fluids) <= n)
- grow_fluids (scm_root, n+1);
- return SCM_SIMPLE_VECTOR_REF (scm_root->fluids, n);
+ return SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
}
#undef FUNC_NAME
+SCM
+scm_i_fast_fluid_ref (size_t n)
+{
+ SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
+ return SCM_SIMPLE_VECTOR_REF (fluids, n);
+}
+
SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
(SCM fluid, SCM value),
"Set the value associated with @var{fluid} in the current dynamic root.")
#define FUNC_NAME s_scm_fluid_set_x
{
- unsigned long int n;
+ SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
SCM_VALIDATE_FLUID (1, fluid);
- n = SCM_FLUID_NUM (fluid);
-
- if (SCM_SIMPLE_VECTOR_LENGTH (scm_root->fluids) <= n)
- grow_fluids (scm_root, n+1);
- SCM_SIMPLE_VECTOR_SET (scm_root->fluids, n, value);
+ SCM_SIMPLE_VECTOR_SET (fluids, FLUID_NUM (fluid), value);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+void
+scm_i_fast_fluid_set_x (size_t n, SCM value)
+{
+ SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
+ SCM_SIMPLE_VECTOR_SET (fluids, n, value);
+}
+
static void
swap_fluids (SCM data)
{
@@ -170,7 +352,8 @@ swap_fluids (SCM data)
}
/* Swap the fluid values in reverse order. This is important when the
-same fluid appears multiple times in the fluids list. */
+ same fluid appears multiple times in the fluids list.
+*/
static void
swap_fluids_reverse_aux (SCM fluids, SCM vals)
@@ -282,11 +465,143 @@ scm_frame_fluid (SCM fluid, SCM value)
scm_frame_unwind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
}
+SCM
+scm_i_make_initial_dynamic_state ()
+{
+ SCM fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F);
+ SCM state;
+ SCM_NEWSMOB2 (state, tc16_dynamic_state,
+ SCM_UNPACK (fluids), SCM_UNPACK (SCM_EOL));
+ all_dynamic_states = state;
+ return state;
+}
+
+SCM_DEFINE (scm_make_dynamic_state, "make-dynamic-state", 0, 1, 0,
+ (SCM parent),
+ "Return a copy of the dynamic state object @var{parent}\n"
+ "or of the current dynamic state when @var{parent} is omitted.")
+#define FUNC_NAME s_scm_make_dynamic_state
+{
+ SCM fluids, state;
+
+ if (SCM_UNBNDP (parent))
+ parent = scm_current_dynamic_state ();
+
+ scm_assert_smob_type (tc16_dynamic_state, parent);
+ fluids = scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent));
+ SCM_NEWSMOB2 (state, tc16_dynamic_state,
+ SCM_UNPACK (fluids), SCM_UNPACK (SCM_EOL));
+
+ /* The GC must not run until the state is properly entered into the
+ list.
+ */
+ SET_DYNAMIC_STATE_NEXT (state, all_dynamic_states);
+ all_dynamic_states = state;
+
+ //fprintf (stderr, "new state %p\n", state);
+ return state;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_dynamic_state_p, "dynamic-state?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a dynamic state object;\n"
+ "return @code{#f} otherwise")
+#define FUNC_NAME s_scm_dynamic_state_p
+{
+ return scm_from_bool (IS_DYNAMIC_STATE (obj));
+}
+#undef FUNC_NAME
+
+int
+scm_is_dynamic_state (SCM obj)
+{
+ return IS_DYNAMIC_STATE (obj);
+}
+
+SCM_DEFINE (scm_current_dynamic_state, "current-dynamic-state", 0, 0, 0,
+ (),
+ "Return the current dynamic state object.")
+#define FUNC_NAME s_scm_current_dynamic_state
+{
+ return SCM_I_CURRENT_THREAD->dynamic_state;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_current_dynamic_state, "set-current-dynamic-state", 1,0,0,
+ (SCM state),
+ "Set the current dynamic state object to @var{state}\n"
+ "and return the previous current dynamic state object.")
+#define FUNC_NAME s_scm_set_current_dynamic_state
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ SCM old = t->dynamic_state;
+ scm_assert_smob_type (tc16_dynamic_state, state);
+ t->dynamic_state = state;
+ return old;
+}
+#undef FUNC_NAME
+
+static void
+swap_dynamic_state (SCM loc)
+{
+ SCM_SETCAR (loc, scm_set_current_dynamic_state (SCM_CAR (loc)));
+}
+
+void
+scm_frame_current_dynamic_state (SCM state)
+{
+ SCM loc = scm_cons (state, SCM_EOL);
+ scm_assert_smob_type (tc16_dynamic_state, state);
+ scm_frame_rewind_handler_with_scm (swap_dynamic_state, loc,
+ SCM_F_WIND_EXPLICITLY);
+ scm_frame_unwind_handler_with_scm (swap_dynamic_state, loc,
+ SCM_F_WIND_EXPLICITLY);
+}
+
+void *
+scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data)
+{
+ void *result;
+ scm_frame_begin (SCM_F_FRAME_REWINDABLE);
+ scm_frame_current_dynamic_state (state);
+ result = func (data);
+ scm_frame_end ();
+ return result;
+}
+
+SCM_DEFINE (scm_with_dynamic_state, "with-dynamic-state", 2, 0, 0,
+ (SCM state, SCM proc),
+ "Call @var{proc} while @var{state} is the current dynamic\n"
+ "state object.")
+#define FUNC_NAME s_scm_with_dynamic_state
+{
+ SCM result;
+ scm_frame_begin (SCM_F_FRAME_REWINDABLE);
+ scm_frame_current_dynamic_state (state);
+ result = scm_call_0 (proc);
+ scm_frame_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+void
+scm_fluids_prehistory ()
+{
+ tc16_fluid = scm_make_smob_type ("fluid", 0);
+ scm_set_smob_free (tc16_fluid, fluid_free);
+ scm_set_smob_print (tc16_fluid, fluid_print);
+
+ tc16_dynamic_state = scm_make_smob_type ("dynamic-state", 0);
+ scm_set_smob_mark (tc16_dynamic_state, scm_markcdr);
+
+ scm_c_hook_add (&scm_after_sweep_c_hook, scan_dynamic_states_and_fluids,
+ 0, 0);
+}
+
void
scm_init_fluids ()
{
- scm_tc16_fluid = scm_make_smob_type ("fluid", 0);
- scm_set_smob_print (scm_tc16_fluid, fluid_print);
#include "libguile/fluids.x"
}
diff --git a/libguile/fluids.h b/libguile/fluids.h
index 0a60bac9e..e5153883b 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -29,46 +29,39 @@
/* Fluids.
Fluids are objects of a certain type (a smob) that can hold one SCM
- value per dynamic root. That is, modifications to this value are
- only visible to code that executes within the same dynamic root as
- the modifying code. When a new dynamic root is constructed, it
+ value per dynamic state. That is, modifications to this value are
+ only visible to code that executes with the same dynamic state as
+ the modifying code. When a new dynamic state is constructed, it
inherits the values from its parent. Because each thread executes
- in its own dynamic root, you can use fluids for thread local
+ with its own dynamic state, you can use fluids for thread local
storage.
Each fluid is identified by a small integer. This integer is used
- to index a vector that holds the values of all fluids. Each root
- has its own vector.
-
- Currently, you can't get rid a certain fluid if you don't use it
- any longer. The slot that has been allocated for it in the fluid
- vector will not be reused for other fluids. Therefore, only use
- SCM_MAKE_FLUID or its Scheme variant `make-fluid' in initialization
- code that is only run once. Nevertheless, it should be possible to
- implement a more lightweight version of fluids on top of this basic
- mechanism. */
-
-SCM_API scm_t_bits scm_tc16_fluid;
-
-#define SCM_FLUIDP(x) (SCM_SMOB_PREDICATE (scm_tc16_fluid, (x)))
-#define SCM_FLUID_NUM(x) (SCM_CELL_WORD_1 (x))
+ to index a vector that holds the values of all fluids. A dynamic
+ state consists of this vector, wrapped in a smob so that the vector
+ can grow.
+ */
/* The fastest way to acces/modify the value of a fluid. These macros
-do no error checking at all. You should only use them when you know
-that the relevant fluid already exists in the current dynamic root.
-The easiest way to ensure this is to execute a SCM_FLUID_SET_X in the
-topmost root, for example right after SCM_MAKE_FLUID in your
-SCM_INIT_MUMBLE routine that gets called from SCM_BOOT_GUILE_1. The
-first argument is the index number of the fluid, obtained via
-SCM_FLUID_NUM, not the fluid itself. */
+ do no error checking at all. The first argument is the index
+ number of the fluid, obtained via SCM_FLUID_NUM, not the fluid
+ itself. You must make sure that the fluid remains protected as
+ long you use its number since numbers of unused fluids are reused
+ eventually.
+*/
-#define SCM_FAST_FLUID_REF(n) (SCM_VELTS(scm_root->fluids)[n])
-#define SCM_FAST_FLUID_SET_X(n, val) (SCM_VELTS(scm_root->fluids)[n] = val)
+#define SCM_FLUID_NUM(x) scm_i_fluid_num (x)
+#define SCM_FAST_FLUID_REF(n) scm_i_fast_fluid_ref (n)
+#define SCM_FAST_FLUID_SET_X(n, val) scm_i_fast_fluid_set_x ((n),(val))
SCM_API SCM scm_make_fluid (void);
+SCM_API int scm_is_fluid (SCM obj);
SCM_API SCM scm_fluid_p (SCM fl);
SCM_API SCM scm_fluid_ref (SCM fluid);
SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
+SCM_API size_t scm_i_fluid_num (SCM fl);
+SCM_API SCM scm_i_fast_fluid_ref (size_t n);
+SCM_API void scm_i_fast_fluid_set_x (size_t n, SCM val);
SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals,
SCM (*cproc)(void *), void *cdata);
@@ -79,9 +72,19 @@ SCM_API SCM scm_with_fluid (SCM fluid, SCM val, SCM thunk);
SCM_API void scm_frame_fluid (SCM fluid, SCM value);
-SCM_API SCM scm_i_make_initial_fluids (void);
-SCM_API void scm_i_copy_fluids (scm_root_state *);
+SCM_API SCM scm_make_dynamic_state (SCM parent);
+SCM_API SCM scm_dynamic_state_p (SCM obj);
+SCM_API int scm_is_dynamic_state (SCM obj);
+SCM_API SCM scm_current_dynamic_state (void);
+SCM_API SCM scm_set_current_dynamic_state (SCM state);
+SCM_API void scm_frame_current_dynamic_state (SCM state);
+SCM_API void *scm_c_with_dynamic_state (SCM state,
+ void *(*func)(void *), void *data);
+SCM_API SCM scm_with_dynamic_state (SCM state, SCM proc);
+
+SCM_API SCM scm_i_make_initial_dynamic_state (void);
+SCM_API void scm_fluids_prehistory (void);
SCM_API void scm_init_fluids (void);
#endif /* SCM_FLUIDS_H */
diff --git a/libguile/fports.c b/libguile/fports.c
index 9d8d1f48a..531de4aa7 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -201,7 +201,7 @@ scm_evict_ports (int fd)
{
long i;
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
for (i = 0; i < scm_i_port_table_size; i++)
{
@@ -221,7 +221,7 @@ scm_evict_ports (int fd)
}
}
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
}
@@ -425,7 +425,7 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
}
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_i_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);
@@ -443,7 +443,7 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
scm_fport_buffer_add (port, -1, -1);
}
SCM_SET_FILENAME (port, name);
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return port;
}
#undef FUNC_NAME
@@ -545,7 +545,7 @@ fport_wait_for_input (SCM port)
{
FD_ZERO (&readfds);
FD_SET (fdes, &readfds);
- n = scm_internal_select (fdes + 1, &readfds, NULL, NULL, NULL);
+ n = scm_std_select (fdes + 1, &readfds, NULL, NULL, NULL);
}
while (n == -1 && errno == EINTR);
}
diff --git a/libguile/futures.c b/libguile/futures.c
index 0f6000a7a..69d208c7e 100644
--- a/libguile/futures.c
+++ b/libguile/futures.c
@@ -39,7 +39,7 @@ do { \
list = SCM_FUTURE_NEXT (list); \
} while (0)
-SCM_MUTEX (future_admin_mutex);
+scm_i_pthread_mutex_t future_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
static SCM futures = SCM_EOL;
static SCM young = SCM_EOL;
@@ -99,8 +99,8 @@ static char *s_future = "future";
static void
cleanup (scm_t_future *future)
{
- scm_mutex_destroy (&future->mutex);
- scm_cond_destroy (&future->cond);
+ scm_i_pthread_mutex_destroy (&future->mutex);
+ scm_i_pthread_cond_destroy (&future->cond);
scm_gc_free (future, sizeof (*future), s_future);
#ifdef SCM_FUTURES_DEBUG
++n_dead;
@@ -110,18 +110,18 @@ cleanup (scm_t_future *future)
static SCM
future_loop (scm_t_future *future)
{
- scm_mutex_lock (&future->mutex);
+ scm_i_scm_pthread_mutex_lock (&future->mutex);
do {
if (future->status == SCM_FUTURE_SIGNAL_ME)
- scm_cond_broadcast (&future->cond);
+ scm_i_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_i_scm_pthread_cond_wait (&future->cond, &future->mutex);
} while (!future->die_p);
future->status = SCM_FUTURE_DEAD;
- scm_mutex_unlock (&future->mutex);
+ scm_i_pthread_mutex_unlock (&future->mutex);
return SCM_UNSPECIFIED;
}
@@ -129,7 +129,7 @@ static SCM
future_handler (scm_t_future *future, SCM key, SCM args)
{
future->status = SCM_FUTURE_DEAD;
- scm_mutex_unlock (&future->mutex);
+ scm_i_pthread_mutex_unlock (&future->mutex);
return scm_apply_1 (*scm_loc_sys_thread_handler, key, args);
}
@@ -139,15 +139,15 @@ alloc_future (SCM thunk)
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);
+ scm_i_pthread_mutex_init (&f->mutex, NULL);
+ scm_i_pthread_cond_init (&f->cond, NULL);
f->die_p = 0;
f->status = SCM_FUTURE_TASK_ASSIGNED;
- scm_mutex_lock (&future_admin_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&future_admin_mutex);
scm_spawn_thread ((scm_t_catch_body) future_loop,
SCM_FUTURE (future),
(scm_t_catch_handler) future_handler,
@@ -166,7 +166,7 @@ SCM
scm_i_make_future (SCM thunk)
{
SCM future;
- scm_mutex_lock (&future_admin_mutex);
+ scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
while (1)
{
if (!scm_is_null (old))
@@ -175,25 +175,25 @@ scm_i_make_future (SCM thunk)
UNLINK (young, future);
else
{
- scm_mutex_unlock (&future_admin_mutex);
+ scm_i_pthread_mutex_unlock (&future_admin_mutex);
return alloc_future (thunk);
}
- if (scm_mutex_trylock (SCM_FUTURE_MUTEX (future)))
+ if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (future)))
kill_future (future);
else if (!SCM_FUTURE_ALIVE_P (future))
{
- scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
cleanup (SCM_FUTURE (future));
}
else
break;
}
LINK (futures, future);
- scm_mutex_unlock (&future_admin_mutex);
+ scm_i_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));
+ scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
+ scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
return future;
}
@@ -223,20 +223,21 @@ SCM_DEFINE (scm_future_ref, "future-ref", 1, 0, 0,
{
SCM res;
SCM_VALIDATE_FUTURE (1, future);
- scm_mutex_lock (SCM_FUTURE_MUTEX (future));
+ scm_i_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_i_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));
+ scm_i_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));
+ scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
return res;
}
#undef FUNC_NAME
@@ -249,7 +250,7 @@ kill_futures (SCM victims)
SCM future;
UNLINK (victims, future);
kill_future (future);
- scm_cond_signal (SCM_FUTURE_COND (future));
+ scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
}
}
@@ -259,12 +260,12 @@ cleanup_undead ()
SCM next = undead, *nextloc = &undead;
while (!scm_is_null (next))
{
- if (scm_mutex_trylock (SCM_FUTURE_MUTEX (next)))
+ if (scm_i_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));
+ scm_i_pthread_cond_signal (SCM_FUTURE_COND (next));
+ scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (next));
next:
SCM_SET_GC_MARK (next);
nextloc = SCM_FUTURE_NEXTLOC (next);
@@ -274,7 +275,7 @@ cleanup_undead ()
{
SCM future;
UNLINK (next, future);
- scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
cleanup (SCM_FUTURE (future));
*nextloc = next;
}
@@ -341,6 +342,8 @@ scan_futures (void *dummy1, void *dummy2, void *dummy3)
return 0;
}
+scm_t_bits scm_tc16_future;
+
void
scm_init_futures ()
{
diff --git a/libguile/futures.h b/libguile/futures.h
index 2654be10e..0c3b0b0a6 100644
--- a/libguile/futures.h
+++ b/libguile/futures.h
@@ -29,8 +29,8 @@
typedef struct scm_t_future {
SCM data;
- scm_t_mutex mutex;
- scm_t_cond cond;
+ scm_i_pthread_mutex_t mutex;
+ scm_i_pthread_cond_t cond;
int status;
int die_p;
} scm_t_future;
diff --git a/libguile/gc-freelist.c b/libguile/gc-freelist.c
index e9863695e..15145fa40 100644
--- a/libguile/gc-freelist.c
+++ b/libguile/gc-freelist.c
@@ -145,12 +145,6 @@ scm_gc_init_freelist (void)
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,
diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
index b909e9424..127805eb0 100644
--- a/libguile/gc-malloc.c
+++ b/libguile/gc-malloc.c
@@ -110,21 +110,21 @@ scm_realloc (void *mem, size_t size)
if (ptr)
return ptr;
- scm_rec_mutex_lock (&scm_i_sweep_mutex);
+ scm_i_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);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
SCM_SYSCALL (ptr = realloc (mem, size));
if (ptr)
@@ -180,10 +180,10 @@ scm_strdup (const char *str)
static void
decrease_mtrigger (size_t size, const char * what)
{
- scm_i_plugin_mutex_lock (&scm_i_gc_admin_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
}
static void
@@ -192,7 +192,7 @@ increase_mtrigger (size_t size, const char *what)
size_t mallocated = 0;
int overflow = 0, triggered = 0;
- scm_i_plugin_mutex_lock (&scm_i_gc_admin_mutex);
+ scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
if (ULONG_MAX - size < scm_mallocated)
overflow = 1;
else
@@ -202,12 +202,10 @@ increase_mtrigger (size_t size, const char *what)
if (scm_mallocated > scm_mtrigger)
triggered = 1;
}
- scm_i_plugin_mutex_unlock (&scm_i_gc_admin_mutex);
+ scm_i_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,
@@ -220,7 +218,7 @@ increase_mtrigger (size_t size, const char *what)
unsigned long prev_alloced;
float yield;
- scm_rec_mutex_lock (&scm_i_sweep_mutex);
+ scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
prev_alloced = mallocated;
scm_igc (what);
@@ -265,7 +263,7 @@ increase_mtrigger (size_t size, const char *what)
#endif
}
- scm_rec_mutex_unlock (&scm_i_sweep_mutex);
+ scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
}
}
diff --git a/libguile/gc.c b/libguile/gc.c
index 0f3c98c18..9ff2d41ee 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -15,6 +15,7 @@
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
+#define _GNU_SOURCE
/* #define DEBUGINFO */
@@ -52,6 +53,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
#include "libguile/validate.h"
#include "libguile/deprecation.h"
#include "libguile/gc.h"
+#include "libguile/dynwind.h"
#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
@@ -71,7 +73,7 @@ unsigned int scm_gc_running_p = 0;
/* Lock this mutex before doing lazy sweeping.
*/
-scm_t_rec_mutex scm_i_sweep_mutex;
+scm_i_pthread_mutex_t scm_i_sweep_mutex = SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER;
/* Set this to != 0 if every cell that is accessed shall be checked:
*/
@@ -206,9 +208,6 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
-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.
@@ -327,7 +326,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
SCM answer;
unsigned long *bounds = 0;
int table_size = scm_i_heap_segment_table_size;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
/*
temporarily store the numbers, so as not to cause GC.
@@ -399,7 +398,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
scm_from_ulong (local_protected_obj_count)),
scm_cons (sym_heap_segments, heap_segs),
SCM_UNDEFINED);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
free (bounds);
return answer;
@@ -474,7 +473,7 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells)
{
SCM cell;
- scm_rec_mutex_lock (&scm_i_sweep_mutex);
+ scm_i_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))
@@ -516,7 +515,7 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells)
*free_cells = SCM_FREE_CELL_CDR (cell);
- scm_rec_mutex_unlock (&scm_i_sweep_mutex);
+ scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
return cell;
}
@@ -531,7 +530,14 @@ scm_t_c_hook scm_after_gc_c_hook;
void
scm_igc (const char *what)
{
- scm_rec_mutex_lock (&scm_i_sweep_mutex);
+ if (scm_block_gc)
+ return;
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
+
+ /* During the critical section, only the current thread may run. */
+ scm_i_thread_put_to_sleep ();
+
++scm_gc_running_p;
scm_c_hook_run (&scm_before_gc_c_hook, 0);
@@ -544,15 +550,6 @@ scm_igc (const char *what)
: (scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist2)) ? "o" : "m"));
#endif
- /* During the critical section, only the current thread may run. */
- scm_i_thread_put_to_sleep ();
-
- if (!scm_root || !scm_stack_base || scm_block_gc)
- {
- --scm_gc_running_p;
- return;
- }
-
gc_start_stats (what);
@@ -637,14 +634,14 @@ scm_igc (const char *what)
scm_c_hook_run (&scm_after_sweep_c_hook, 0);
gc_end_stats ();
+ --scm_gc_running_p;
scm_i_thread_wake_up ();
/*
See above.
*/
- --scm_gc_running_p;
+ scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
scm_c_hook_run (&scm_after_gc_c_hook, 0);
- scm_rec_mutex_unlock (&scm_i_sweep_mutex);
/*
For debugging purposes, you could do
@@ -731,9 +728,11 @@ scm_return_first_int (int i, ...)
SCM
scm_permanent_object (SCM obj)
{
- SCM_REDEFER_INTS;
- scm_permobjs = scm_cons (obj, scm_permobjs);
- SCM_REALLOW_INTS;
+ SCM cell = scm_cons (obj, SCM_EOL);
+ SCM_CRITICAL_SECTION_START;
+ SCM_SETCDR (cell, scm_permobjs);
+ scm_permobjs = cell;
+ SCM_CRITICAL_SECTION_END;
return obj;
}
@@ -760,14 +759,14 @@ scm_gc_protect_object (SCM obj)
SCM handle;
/* This critical section barrier will be replaced by a mutex. */
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0));
SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
protected_obj_count ++;
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return obj;
}
@@ -783,7 +782,7 @@ scm_gc_unprotect_object (SCM obj)
SCM handle;
/* This critical section barrier will be replaced by a mutex. */
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
if (scm_gc_running_p)
{
@@ -808,7 +807,7 @@ scm_gc_unprotect_object (SCM obj)
}
protected_obj_count --;
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return obj;
}
@@ -820,13 +819,13 @@ scm_gc_register_root (SCM *p)
SCM key = scm_from_ulong ((unsigned long) p);
/* This critical section barrier will be replaced by a mutex. */
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
handle = scm_hashv_create_handle_x (scm_gc_registered_roots, key,
scm_from_int (0));
SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
}
void
@@ -836,7 +835,7 @@ scm_gc_unregister_root (SCM *p)
SCM key = scm_from_ulong ((unsigned long) p);
/* This critical section barrier will be replaced by a mutex. */
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
handle = scm_hashv_get_handle (scm_gc_registered_roots, key);
@@ -854,7 +853,7 @@ scm_gc_unregister_root (SCM *p)
SCM_SETCDR (handle, count);
}
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
}
void
@@ -875,25 +874,6 @@ scm_gc_unregister_roots (SCM *b, unsigned long n)
int scm_i_terminating;
-/* called on process termination. */
-#ifdef HAVE_ATEXIT
-static void
-cleanup (void)
-#else
-#ifdef HAVE_ON_EXIT
-extern int on_exit (void (*procp) (), int arg);
-
-static void
-cleanup (int status, void *arg)
-#else
-#error Dont know how to setup a cleanup handler on your system.
-#endif
-#endif
-{
- scm_i_terminating = 1;
- scm_flush_all_ports ();
-}
-
@@ -926,18 +906,13 @@ scm_storage_prehistory ()
scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
}
-scm_t_mutex scm_i_gc_admin_mutex;
+scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_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;
@@ -955,6 +930,10 @@ scm_init_storage ()
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
@@ -963,6 +942,8 @@ scm_init_storage ()
#endif
#endif
+#endif
+
scm_stand_in_procs = scm_c_make_hash_table (257);
scm_permobjs = SCM_EOL;
scm_protects = scm_c_make_hash_table (31);
@@ -1023,6 +1004,7 @@ mark_gc_async (void * hook_data SCM_UNUSED,
* collection hooks and the execution count of the scheme level
* after-gc-hook.
*/
+
#if (SCM_DEBUG_CELL_ACCESSES == 1)
if (scm_debug_cells_gc_interval == 0)
scm_system_async_mark (gc_async);
diff --git a/libguile/gc.h b/libguile/gc.h
index 54888846a..4cb78a714 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -25,12 +25,7 @@
#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"
@@ -230,12 +225,12 @@ SCM_API int scm_debug_cells_gc_interval ;
void scm_i_expensive_validation_check (SCM cell);
#endif
-SCM_API scm_t_mutex scm_i_gc_admin_mutex;
+SCM_API scm_i_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 scm_i_pthread_mutex_t scm_i_sweep_mutex;
#if (SCM_ENABLE_DEPRECATED == 1)
@@ -255,13 +250,10 @@ SCM_API size_t scm_default_max_segment_size;
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) scm_i_pthread_setspecific ((key), (ptr))
+#define SCM_FREELIST_LOC(key) ((SCM *) scm_i_pthread_getspecific (key))
+SCM_API scm_i_pthread_key_t scm_i_freelist;
+SCM_API scm_i_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;
diff --git a/libguile/gh.h b/libguile/gh.h
index 64a6579cc..cc230cfa0 100644
--- a/libguile/gh.h
+++ b/libguile/gh.h
@@ -55,8 +55,8 @@ SCM_API SCM gh_eval_file(const char *fname);
SCM_API SCM gh_eval_file_with_catch(const char *scheme_code, scm_t_catch_handler handler);
SCM_API SCM gh_eval_file_with_standard_handler(const char *scheme_code);
-#define gh_defer_ints() SCM_DEFER_INTS
-#define gh_allow_ints() SCM_ALLOW_INTS
+#define gh_defer_ints() SCM_CRITICAL_SECTION_START
+#define gh_allow_ints() SCM_CRITICAL_SECTION_END
SCM_API SCM gh_new_procedure(const char *proc_name, SCM (*fn)(),
int n_required_args, int n_optional_args,
diff --git a/libguile/goops.c b/libguile/goops.c
index 41aa6433a..b1aa22176 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1617,7 +1617,7 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
* scratch the old value with new to be correct with GC.
* See "Class redefinition protocol above".
*/
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
{
SCM car = SCM_CAR (old);
SCM cdr = SCM_CDR (old);
@@ -1626,7 +1626,7 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
SCM_SETCAR (new, car);
SCM_SETCDR (new, cdr);
}
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1639,7 +1639,7 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
SCM_VALIDATE_CLASS (1, old);
SCM_VALIDATE_CLASS (2, new);
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
{
SCM car = SCM_CAR (old);
SCM cdr = SCM_CDR (old);
@@ -1650,7 +1650,7 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
SCM_SETCDR (new, cdr);
SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
}
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
diff --git a/libguile/guardians.c b/libguile/guardians.c
index e3977e901..4d4f5a140 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -225,14 +225,14 @@ scm_guard (SCM guardian, SCM obj, int throw_p)
SCM z;
/* This critical section barrier will be replaced by a mutex. */
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
if (GREEDY_P (g))
{
if (scm_is_true (scm_hashq_get_handle
(greedily_guarded_whash, obj)))
{
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
if (throw_p)
scm_misc_error ("guard",
@@ -249,7 +249,7 @@ scm_guard (SCM guardian, SCM obj, int throw_p)
z = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
TCONC_IN (g->live, obj, z);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
}
return throw_p ? SCM_UNSPECIFIED : SCM_BOOL_T;
@@ -263,7 +263,7 @@ scm_get_one_zombie (SCM guardian)
SCM res = SCM_BOOL_F;
/* This critical section barrier will be replaced by a mutex. */
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
if (!TCONC_EMPTYP (g->zombies))
TCONC_OUT (g->zombies, res);
@@ -271,7 +271,7 @@ scm_get_one_zombie (SCM guardian)
if (scm_is_true (res) && GREEDY_P (g))
scm_hashq_remove_x (greedily_guarded_whash, res);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return res;
}
@@ -337,11 +337,11 @@ SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0,
SCM res = SCM_BOOL_F;
/* This critical section barrier will be replaced by a mutex. */
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
res = scm_from_bool (DESTROYED_P (GUARDIAN_DATA (guardian)));
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return res;
}
@@ -366,11 +366,11 @@ SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0,
t_guardian *g = GUARDIAN_DATA (guardian);
/* This critical section barrier will be replaced by a mutex. */
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
if (DESTROYED_P (g))
{
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
SCM_MISC_ERROR ("guardian is already destroyed: ~A",
scm_list_1 (guardian));
}
@@ -391,7 +391,7 @@ SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0,
SET_DESTROYED (g);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
}
@@ -569,16 +569,17 @@ whine_about_self_centered_zombies (void *dummy1 SCM_UNUSED,
{
if (!scm_is_null (self_centered_zombies))
{
+ SCM port = scm_current_error_port ();
SCM pair;
scm_puts ("** WARNING: the following guarded objects were unguarded due to cycles:",
- scm_cur_errp);
- scm_newline (scm_cur_errp);
+ port);
+ scm_newline (port);
for (pair = self_centered_zombies;
!scm_is_null (pair); pair = SCM_CDR (pair))
{
- scm_display (SCM_CAR (pair), scm_cur_errp);
- scm_newline (scm_cur_errp);
+ scm_display (SCM_CAR (pair), port);
+ scm_newline (port);
}
self_centered_zombies = SCM_EOL;
diff --git a/libguile/init.c b/libguile/init.c
index ca964afb3..69e1320c4 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -133,46 +133,6 @@
#include <unistd.h>
#endif
-/* 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
@@ -283,18 +243,18 @@ scm_init_standard_ports ()
buffered input on stdin can reset \ex{(current-input-port)} to
block buffering for higher performance. */
- scm_cur_inp
- = scm_standard_stream_to_port (0,
- isatty (0) ? "r0" : "r",
- "standard input");
- scm_cur_outp = scm_standard_stream_to_port (1,
- isatty (1) ? "w0" : "w",
- "standard output");
- scm_cur_errp = scm_standard_stream_to_port (2,
- isatty (2) ? "w0" : "w",
- "standard error");
-
- scm_cur_loadp = SCM_BOOL_F;
+ scm_set_current_input_port
+ (scm_standard_stream_to_port (0,
+ isatty (0) ? "r0" : "r",
+ "standard input"));
+ scm_set_current_output_port
+ (scm_standard_stream_to_port (1,
+ isatty (1) ? "w0" : "w",
+ "standard output"));
+ scm_set_current_error_port
+ (scm_standard_stream_to_port (2,
+ isatty (2) ? "w0" : "w",
+ "standard error"));
}
@@ -345,11 +305,7 @@ struct main_func_closure
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.
@@ -383,10 +339,6 @@ static SCM invoke_main_func(void *body_data);
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;
@@ -394,19 +346,55 @@ scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
c.argc = argc;
c.argv = argv;
- scm_boot_guile_1 (&dummy, &c);
+ scm_with_guile (invoke_main_func, &c);
}
-void
-scm_init_guile ()
+static void *
+invoke_main_func (void *body_data)
{
- scm_init_guile_1 ((SCM_STACKITEM *)scm_get_stack_base ());
+ 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.
+ */
+ exit (0);
+
+ /* never reached */
+ return NULL;
}
+scm_i_pthread_mutex_t scm_i_init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
int scm_initialized_p = 0;
+static void *
+really_cleanup_for_exit (void *unused)
+{
+ scm_flush_all_ports ();
+ return NULL;
+}
+
static void
-scm_init_guile_1 (SCM_STACKITEM *base)
+cleanup_for_exit ()
+{
+ /* This function might be called in non-guile mode, so we need to
+ enter it temporarily.
+ */
+ scm_with_guile (really_cleanup_for_exit, NULL);
+}
+
+void
+scm_i_init_guile (SCM_STACKITEM *base)
{
if (scm_initialized_p)
return;
@@ -427,9 +415,10 @@ scm_init_guile_1 (SCM_STACKITEM *base)
scm_block_gc = 1;
scm_storage_prehistory ();
- scm_threads_prehistory ();
+ scm_threads_prehistory (base);
scm_ports_prehistory ();
scm_smob_prehistory ();
+ scm_fluids_prehistory ();
scm_hashtab_prehistory (); /* requires storage_prehistory */
#ifdef GUILE_DEBUG_MALLOC
scm_debug_malloc_prehistory ();
@@ -448,13 +437,11 @@ scm_init_guile_1 (SCM_STACKITEM *base)
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 (); /* requires fluids */
scm_init_gsubr ();
scm_init_thread_procs (); /* requires gsubrs */
scm_init_procprop ();
scm_init_environments ();
- scm_init_feature ();
scm_init_alist ();
scm_init_arbiters ();
scm_init_async ();
@@ -466,8 +453,9 @@ scm_init_guile_1 (SCM_STACKITEM *base)
scm_init_dynwind ();
scm_init_eq ();
scm_init_error ();
- scm_init_fluids ();
scm_init_futures ();
+ scm_init_fluids ();
+ scm_init_feature (); /* Requires fluids */
scm_init_backtrace (); /* Requires fluids */
scm_init_fports ();
scm_init_strports ();
@@ -551,6 +539,8 @@ scm_init_guile_1 (SCM_STACKITEM *base)
scm_i_init_deprecated ();
#endif
+ scm_init_threads_default_dynamic_state ();
+
scm_initialized_p = 1;
scm_block_gc = 0; /* permit the gc to run */
@@ -564,54 +554,10 @@ scm_init_guile_1 (SCM_STACKITEM *base)
scm_init_rw ();
scm_init_extensions ();
+ atexit (cleanup_for_exit);
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:
c-file-style: "gnu"
diff --git a/libguile/init.h b/libguile/init.h
index ac8e626d2..a0425f33f 100644
--- a/libguile/init.h
+++ b/libguile/init.h
@@ -23,8 +23,10 @@
#include "libguile/__scm.h"
+#include "libguile/threads.h"
+SCM_API scm_i_pthread_mutex_t scm_i_init_mutex;
SCM_API int scm_initialized_p;
SCM_API void scm_init_guile (void);
@@ -35,6 +37,8 @@ SCM_API void scm_boot_guile (int argc, char **argv,
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 */
diff --git a/libguile/ioext.c b/libguile/ioext.c
index 22a2de57e..fb2f549bf 100644
--- a/libguile/ioext.c
+++ b/libguile/ioext.c
@@ -280,14 +280,14 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
int_fd = scm_to_int (fd);
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return result;
}
#undef FUNC_NAME
diff --git a/libguile/iselect.h b/libguile/iselect.h
index 37af2a430..7078fc9c6 100644
--- a/libguile/iselect.h
+++ b/libguile/iselect.h
@@ -52,21 +52,11 @@
#endif /* no FD_SET */
-SCM_API int scm_internal_select (int fds,
- SELECT_TYPE *rfds,
- SELECT_TYPE *wfds,
- SELECT_TYPE *efds,
- struct timeval *timeout);
-
-#if SCM_USE_COOP_THREADS
-
-SCM_API int scm_I_am_dead;
-
-SCM_API void scm_error_revive_threads (void);
-
-#endif /* SCM_USE_COOP_THREADS */
-
-SCM_API void scm_init_iselect (void);
+SCM_API int scm_std_select (int fds,
+ SELECT_TYPE *rfds,
+ SELECT_TYPE *wfds,
+ SELECT_TYPE *efds,
+ struct timeval *timeout);
#endif /* SCM_ISELECT_H */
diff --git a/libguile/keywords.c b/libguile/keywords.c
index 3e9b23a6e..f6b570348 100644
--- a/libguile/keywords.c
+++ b/libguile/keywords.c
@@ -64,14 +64,14 @@ SCM_DEFINE (scm_symbol_to_keyword, "symbol->keyword", 1, 0, 0,
SCM_ASSERT_TYPE (scm_is_symbol (symbol), symbol, 0, NULL, "symbol");
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
keyword = scm_hashq_ref (scm_keyword_obarray, symbol, SCM_BOOL_F);
if (scm_is_false (keyword))
{
SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol));
scm_hashq_set_x (scm_keyword_obarray, symbol, keyword);
}
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return keyword;
}
#undef FUNC_NAME
diff --git a/libguile/null-threads.c b/libguile/null-threads.c
index 7f2eb8b43..7b1f85fc9 100644
--- a/libguile/null-threads.c
+++ b/libguile/null-threads.c
@@ -15,318 +15,51 @@
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
+#include <stdlib.h>
+#include "libguile/_scm.h"
-
+#if SCM_USE_NULL_THREADS
-#include "libguile/validate.h"
-#include "libguile/root.h"
-#include "libguile/stackchk.h"
-#include "libguile/async.h"
-#include <sys/time.h>
-#include <sys/types.h>
-#include <time.h>
-#include <stdio.h>
+#include "libguile/null-threads.h"
-void *scm_null_threads_data;
+static scm_i_pthread_key_t *all_keys = NULL;
-static SCM main_thread;
-
-typedef struct {
- int level;
-} scm_null_mutex;
-
-typedef struct {
- int signalled;
-} scm_null_cond;
-
-void
-scm_threads_init (SCM_STACKITEM *i)
-{
- scm_tc16_thread = scm_make_smob_type ("thread", 0);
- scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_null_mutex));
- scm_tc16_condvar = scm_make_smob_type ("condition-variable",
- sizeof (scm_null_cond));
-
- main_thread = scm_permanent_object (scm_cell (scm_tc16_thread, 0));
- scm_null_threads_data = NULL;
-}
-
-#ifdef __ia64__
-# define SCM_MARK_BACKING_STORE() do { \
- ucontext_t ctx; \
- SCM_STACKITEM * top, * bot; \
- getcontext (&ctx); \
- scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
- ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
- / sizeof (SCM_STACKITEM))); \
- bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
- top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
- scm_mark_locations (bot, top - bot); } while (0)
-#else
-# define SCM_MARK_BACKING_STORE()
-#endif
-
-void
-scm_threads_mark_stacks (void)
-{
- /* Mark objects on the C stack. */
- SCM_FLUSH_REGISTER_WINDOWS;
- /* This assumes that all registers are saved into the jmp_buf */
- setjmp (scm_save_regs_gc_mark);
- scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
- ( (size_t) (sizeof (SCM_STACKITEM) - 1 +
- sizeof scm_save_regs_gc_mark)
- / sizeof (SCM_STACKITEM)));
-
- {
- unsigned long stack_len = scm_stack_size (scm_stack_base);
-#if SCM_STACK_GROWS_UP
- scm_mark_locations (scm_stack_base, stack_len);
-#else
- scm_mark_locations (scm_stack_base - stack_len, stack_len);
-#endif
- }
- SCM_MARK_BACKING_STORE();
-}
-
-SCM
-scm_call_with_new_thread (SCM argl)
-#define FUNC_NAME s_call_with_new_thread
-{
- SCM_MISC_ERROR ("threads are not supported in this version of Guile",
- SCM_EOL);
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM
-scm_spawn_thread (scm_t_catch_body body, void *body_data,
- scm_t_catch_handler handler, void *handler_data)
-{
- scm_misc_error ("scm_spawn_thread",
- "threads are not supported in this version of Guile",
- SCM_EOL);
- return SCM_BOOL_F;
-}
-
-SCM
-scm_current_thread (void)
-{
- return main_thread;
-}
-
-SCM
-scm_all_threads (void)
-{
- return scm_list_1 (main_thread);
-}
-
-scm_root_state *
-scm_i_thread_root (SCM thread)
-{
- return (scm_root_state *)scm_null_threads_data;
-}
-
-SCM
-scm_join_thread (SCM thread)
-#define FUNC_NAME s_join_thread
-{
- SCM_MISC_ERROR ("threads are not supported in this version of Guile",
- SCM_EOL);
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-int
-scm_c_thread_exited_p (SCM thread)
-#define FUNC_NAME s_scm_thread_exited_p
-{
- return 0;
-}
-#undef FUNC_NAME
-
-SCM
-scm_yield (void)
-{
- return SCM_BOOL_T;
-}
-
-SCM
-scm_make_mutex (void)
-{
- SCM m = scm_make_smob (scm_tc16_mutex);
- scm_null_mutex *mx = SCM_MUTEX_DATA(m);
- mx->level = 0;
- return m;
-}
-
-SCM
-scm_lock_mutex (SCM m)
-{
- scm_null_mutex *mx;
- SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);
- mx = SCM_MUTEX_DATA(m);
- mx->level++;
- return SCM_BOOL_T;
-}
-
-SCM
-scm_try_mutex (SCM m)
-{
- return scm_lock_mutex (m); /* will always succeed right away. */
-}
-
-SCM
-scm_unlock_mutex (SCM m)
-{
- scm_null_mutex *mx;
- SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_unlock_mutex);
- mx = SCM_MUTEX_DATA(m);
- if (mx->level == 0)
- scm_misc_error (s_unlock_mutex, "mutex is not locked", SCM_EOL);
- mx->level--;
- return SCM_BOOL_T;
-}
-
-SCM
-scm_make_condition_variable (void)
-{
- scm_null_cond *cv;
- SCM c = scm_make_smob (scm_tc16_condvar);
- cv = SCM_CONDVAR_DATA (c);
- cv->signalled = 0;
- return c;
-}
-
-/* Subtract the `struct timeval' values X and Y,
- storing the result in RESULT. Might modify Y.
- Return 1 if the difference is negative or zero, otherwise 0. */
-
-static int
-timeval_subtract (result, x, y)
- struct timeval *result, *x, *y;
+static void
+destroy_keys (void)
{
- /* Perform the carry for the later subtraction by updating Y. */
- if (x->tv_usec < y->tv_usec) {
- int nsec = (y->tv_usec - x->tv_usec) / 1000000 + 1;
- y->tv_usec -= 1000000 * nsec;
- y->tv_sec += nsec;
- }
- if (x->tv_usec - y->tv_usec > 1000000) {
- int nsec = (x->tv_usec - y->tv_usec) / 1000000;
- y->tv_usec += 1000000 * nsec;
- y->tv_sec -= nsec;
- }
-
- /* Compute the time remaining to wait.
- `tv_usec' is certainly positive. */
- result->tv_sec = x->tv_sec - y->tv_sec;
- result->tv_usec = x->tv_usec - y->tv_usec;
-
- /* Return 1 if result is negative or zero. */
- return x->tv_sec < y->tv_sec
- || (result->tv_sec == 0 && result->tv_usec == 0);
-}
-
-SCM
-scm_timed_wait_condition_variable (SCM c, SCM m, SCM t)
-#define FUNC_NAME s_wait_condition_variable
-{
- scm_null_cond *cv;
- struct timeval waittime;
-
- SCM_ASSERT (SCM_CONDVARP (c),
- c,
- SCM_ARG1,
- s_wait_condition_variable);
- SCM_ASSERT (SCM_MUTEXP (m),
- m,
- SCM_ARG2,
- s_wait_condition_variable);
- 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_usec);
- }
- else
- {
- SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec);
- waittime.tv_usec = 0;
- }
- }
-
- cv = SCM_CONDVAR_DATA (c);
+ scm_i_pthread_key_t *key;
+ int again;
- scm_unlock_mutex (m);
- while (!cv->signalled)
- {
- if (SCM_UNBNDP (t))
- select (0, NULL, NULL, NULL, NULL);
- else
+ do {
+ again = 0;
+ for (key = all_keys; key; key = key->next)
+ if (key->value && key->destr_func)
{
- struct timeval now, then, diff;
- then = waittime;
- gettimeofday (&now, NULL);
- if (timeval_subtract (&diff, &then, &now))
- break;
- select (0, NULL, NULL, NULL, &diff);
+ void *v = key->value;
+ key->value = NULL;
+ key->destr_func (v);
+ again = 1;
}
- SCM_ASYNC_TICK;
- }
- scm_lock_mutex (m);
- if (cv->signalled)
- {
- cv->signalled = 0;
- return SCM_BOOL_T;
- }
- return SCM_BOOL_F;
+ } while (again);
}
-#undef FUNC_NAME
-SCM
-scm_signal_condition_variable (SCM c)
+int
+scm_i_pthread_key_create (scm_i_pthread_key_t *key,
+ void (*destr_func) (void *))
{
- scm_null_cond *cv;
- SCM_ASSERT (SCM_CONDVARP (c),
- c,
- SCM_ARG1,
- s_signal_condition_variable);
- cv = SCM_CONDVAR_DATA (c);
- cv->signalled = 1;
- return SCM_BOOL_T;
-}
+ if (all_keys == NULL)
+ atexit (destroy_keys);
-SCM
-scm_broadcast_condition_variable (SCM c)
-{
- return scm_signal_condition_variable (c); /* only one thread anyway. */
-}
+ key->next = all_keys;
+ all_keys = key;
+ key->value = NULL;
+ key->destr_func = destr_func;
-unsigned long
-scm_thread_usleep (unsigned long usec)
-{
- struct timeval timeout;
- timeout.tv_sec = 0;
- timeout.tv_usec = usec;
- select (0, NULL, NULL, NULL, &timeout);
- return 0; /* Maybe we should calculate actual time slept,
- but this is faster... :) */
+ return 0;
}
-unsigned long
-scm_thread_sleep (unsigned long sec)
-{
- time_t now = time (NULL);
- struct timeval timeout;
- unsigned long slept;
- timeout.tv_sec = sec;
- timeout.tv_usec = 0;
- select (0, NULL, NULL, NULL, &timeout);
- slept = time (NULL) - now;
- return slept > sec ? 0 : sec - slept;
-}
+#endif /* SCM_USE_NULL_THREADS */
+
/*
Local Variables:
diff --git a/libguile/null-threads.h b/libguile/null-threads.h
index 9f2a9db67..521add258 100644
--- a/libguile/null-threads.h
+++ b/libguile/null-threads.h
@@ -3,7 +3,7 @@
#ifndef SCM_NULL_THREADS_H
#define SCM_NULL_THREADS_H
-/* Copyright (C) 2002 Free Software Foundation, Inc.
+/* Copyright (C) 2005 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -22,101 +22,81 @@
-/* The null-threads implementation. We provide the standard API, but
- no new threads can be created.
-*/
-
-#error temporarily broken, compile with threads enabled (default option)
+/* The null-threads implementation. We provide the subset of the
+ standard pthread API that is used by Guile, but no new threads can
+ be created.
-/* We can't switch so don't bother trying.
+ This file merely exits so that Guile can be compiled and run
+ without using pthreads. Improving performance via optimizations
+ that are possible in a single-threaded program is not a primary
+ goal.
*/
-#undef SCM_THREAD_SWITCHING_CODE
-#define SCM_THREAD_SWITCHING_CODE
-#define scm_t_thread int
+#include <errno.h>
-/* The "(void)(...)" constructs in the expansions are there to ensure
- that the side effects of the argument expressions take place.
+/* Threads
*/
+#define scm_i_pthread_t int
+#define scm_i_pthread_self() 0
+#define scm_i_pthread_create(t,a,f,d) (*(t)=0, (void)(f), ENOSYS)
+#define scm_i_pthread_detach(t) do { } while (0)
+#define scm_i_pthread_exit(v) exit(0)
+#define scm_i_sched_yield() 0
+
+/* Signals
+ */
+#define scm_i_pthread_sigmask sigprocmask
-#define scm_thread_create(th,proc,data) ((void)(proc), (void)(data), ENOTSUP)
-#define scm_thread_join(th) do { (void)(th); abort(); } while(0)
-#define scm_thread_detach(th) do { (void)(th); abort(); } while(0)
-#define scm_thread_self() 0
-
-#define scm_t_mutex int
-
-#define scm_mutex_init(mx) do { (void)(mx); } while(0)
-#define scm_mutex_destroy(mx) do { (void)(mx); } while(0)
-#define scm_mutex_lock(mx) do { (void)(mx); } while(0)
-#define scm_mutex_trylock(mx) ((void)(mx), 1)
-#define scm_mutex_unlock(mx) do { (void)(mx); } while(0)
-
-#define scm_t_cond int
-
-#define scm_cond_init(cv) do { (void)(cv); } while(0)
-#define scm_cond_destroy(cv) do { (void)(cv); } while(0)
-#define scm_cond_wait(cv,mx) ((void)(cv), (void)(mx), ENOTSUP)
-#define scm_cond_timedwait(cv,mx,at) ((void)(cv), (void)(mx), (void)(at), \
- ENOTSUP)
-#define scm_cond_signal(cv) do { (void)(cv); } while(0)
-#define scm_cond_broadcast(cv) do { (void)(cv); } while(0)
-
-#define scm_thread_select select
-
-typedef void **scm_t_key;
-
-#define scm_key_create(keyp) do { *(keyp) = malloc(sizeof(void*)); \
- } while(0)
-#define scm_key_delete(key) do { free(key); } while(0)
-#define scm_key_setspecific(key, value) do { *(key) = (value); } while(0)
-#define scm_key_getspecific(key) *(key)
-
-#if 0
-
-/* These are the actual prototypes of the functions/macros defined
- above. We list them here for reference. */
-
-typedef int scm_t_thread;
-
-SCM_API int scm_thread_create (scm_t_thread *th,
- void (*proc) (void *), void *data);
-SCM_API void scm_thread_join (scm_t_thread th);
-SCM_API void scm_thread_detach (scm_t_thread th);
-SCM_API scm_t_thread scm_thread_self (void);
-
-typedef int scm_t_mutex;
-
-SCM_API void scm_mutex_init (scm_t_mutex *mx);
-SCM_API void scm_mutex_destroy (scm_t_mutex *mx);
-SCM_API void scm_mutex_lock (scm_t_mutex *mx);
-SCM_API int scm_mutex_trylock (scm_t_mutex *mx);
-SCM_API void scm_mutex_unlock (scm_t_mutex *mx);
-
-typedef int scm_t_cond;
-
-SCM_API void scm_cond_init (scm_t_cond *cv);
-SCM_API void scm_cond_destroy (scm_t_cond *cv);
-SCM_API void scm_cond_wait (scm_t_cond *cv, scm_t_mutex *mx);
-SCM_API int scm_cond_timedwait (scm_t_cond *cv, scm_t_mutex *mx,
- scm_t_timespec *abstime);
-SCM_API void scm_cond_signal (scm_t_cond *cv);
-SCM_API void scm_cond_broadcast (scm_t_cond *cv);
-
-typedef int scm_t_key;
-
-SCM_API void scm_key_create (scm_t_key *keyp);
-SCM_API void scm_key_delete (scm_t_key key);
-SCM_API void scm_key_setspecific (scm_t_key key, const void *value);
-SCM_API void *scm_key_getspecific (scm_t_key key);
+/* Mutexes
+ */
+#define SCM_I_PTHREAD_MUTEX_INITIALIZER 0
+#define SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER 0
+#define scm_i_pthread_mutex_t int
+#define scm_i_pthread_mutex_init(m,a) (*(m) = 0)
+#define scm_i_pthread_mutex_destroy(m) do { (void)(m); } while(0)
+#define scm_i_pthread_mutex_trylock(m) ((*(m))++)
+#define scm_i_pthread_mutex_lock(m) ((*(m))++)
+#define scm_i_pthread_mutex_unlock(m) ((*(m))--)
+
+/* Condition variables
+ */
+#define SCM_I_PTHREAD_COND_INITIALIZER 0
+#define scm_i_pthread_cond_t int
+#define scm_i_pthread_cond_init(c,a) (*(c) = 0)
+#define scm_i_pthread_cond_destroy(c) do { (void)(c); } while(0)
+#define scm_i_pthread_cond_signal(c) (*(c) = 1)
+#define scm_i_pthread_cond_broadcast(c) (*(c) = 1)
+#define scm_i_pthread_cond_wait(c,m) (abort(), 0)
+#define scm_i_pthread_cond_timedwait(c,m,t) (abort(), 0)
+
+/* Onces
+ */
+#define scm_i_pthread_once_t int
+#define SCM_I_PTHREAD_ONCE_INIT 0
+#define scm_i_pthread_once(o,f) do { \
+ if(!*(o)) { *(o)=1; f (); } \
+ } while(0)
-SCM_API int scm_thread_select (int nfds,
- SELECT_TYPE *readfds,
- SELECT_TYPE *writefds,
- SELECT_TYPE *exceptfds,
- struct timeval *timeout);
+/* Thread specific storage
+ */
+typedef struct scm_i_pthread_key_t {
+ struct scm_i_pthread_key_t *next;
+ void *value;
+ void (*destr_func) (void *);
+} scm_i_pthread_key_t;
+
+SCM_API int scm_i_pthread_key_create (scm_i_pthread_key_t *key,
+ void (*destr_func) (void *));
+#define scm_i_pthread_setspecific(k,p) ((k).value = (p))
+#define scm_i_pthread_getspecific(k) ((k).value)
+
+/* Convenience functions
+ */
+#define scm_i_scm_pthread_mutex_lock scm_i_pthread_mutex_lock
+#define scm_i_frame_pthread_mutex_lock scm_i_pthread_mutex_lock
+#define scm_i_scm_pthread_cond_wait scm_i_pthread_cond_wait
+#define scm_i_scm_pthread_cond_timedwait scm_i_pthread_cond_timedwait
-#endif
#endif /* SCM_NULL_THREADS_H */
diff --git a/libguile/objprop.c b/libguile/objprop.c
index 9de436470..55f4b7fb8 100644
--- a/libguile/objprop.c
+++ b/libguile/objprop.c
@@ -71,7 +71,7 @@ SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0,
SCM h;
SCM assoc;
h = scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL);
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
assoc = scm_assq (key, SCM_CDR (h));
if (SCM_NIMP (assoc))
SCM_SETCDR (assoc, value);
@@ -80,7 +80,7 @@ SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0,
assoc = scm_acons (key, value, SCM_CDR (h));
SCM_SETCDR (h, assoc);
}
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return value;
}
#undef FUNC_NAME
diff --git a/libguile/ports.c b/libguile/ports.c
index ffa01f71f..5fe2e0763 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -41,6 +41,7 @@
#include "libguile/validate.h"
#include "libguile/ports.h"
#include "libguile/vectors.h"
+#include "libguile/fluids.h"
#ifdef HAVE_STRING_H
#include <string.h>
@@ -121,7 +122,7 @@ scm_make_port_type (char *name,
char *tmp;
if (255 <= scm_numptob)
goto ptoberr;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs,
(1 + scm_numptob)
* sizeof (scm_t_ptob_descriptor)));
@@ -148,7 +149,7 @@ scm_make_port_type (char *name,
scm_numptob++;
}
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
if (!tmp)
{
ptoberr:
@@ -246,7 +247,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0,
scm_t_port *pt;
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
else
SCM_VALIDATE_OPINPORT (1, port);
@@ -341,6 +342,11 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
/* Standard ports --- current input, output, error, and more(!). */
+static SCM cur_inport_fluid;
+static SCM cur_outport_fluid;
+static SCM cur_errport_fluid;
+static SCM cur_loadport_fluid;
+
SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
(),
"Return the current input port. This is the default port used\n"
@@ -348,7 +354,7 @@ SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
"returns the @dfn{standard input} in Unix and C terminology.")
#define FUNC_NAME s_scm_current_input_port
{
- return scm_cur_inp;
+ return scm_fluid_ref (cur_inport_fluid);
}
#undef FUNC_NAME
@@ -360,7 +366,7 @@ SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
"Unix and C terminology.")
#define FUNC_NAME s_scm_current_output_port
{
- return scm_cur_outp;
+ return scm_fluid_ref (cur_outport_fluid);
}
#undef FUNC_NAME
@@ -370,7 +376,7 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
"@dfn{standard error} in Unix and C terminology).")
#define FUNC_NAME s_scm_current_error_port
{
- return scm_cur_errp;
+ return scm_fluid_ref (cur_errport_fluid);
}
#undef FUNC_NAME
@@ -380,7 +386,7 @@ SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
"The load port is used internally by @code{primitive-load}.")
#define FUNC_NAME s_scm_current_load_port
{
- return scm_cur_loadp;
+ return scm_fluid_ref (cur_loadport_fluid);
}
#undef FUNC_NAME
@@ -393,9 +399,9 @@ SCM_DEFINE (scm_set_current_input_port, "set-current-input-port", 1, 0, 0,
"so that they use the supplied @var{port} for input or output.")
#define FUNC_NAME s_scm_set_current_input_port
{
- SCM oinp = scm_cur_inp;
+ SCM oinp = scm_fluid_ref (cur_inport_fluid);
SCM_VALIDATE_OPINPORT (1, port);
- scm_cur_inp = port;
+ scm_fluid_set_x (cur_inport_fluid, port);
return oinp;
}
#undef FUNC_NAME
@@ -406,10 +412,10 @@ SCM_DEFINE (scm_set_current_output_port, "set-current-output-port", 1, 0, 0,
"Set the current default output port to @var{port}.")
#define FUNC_NAME s_scm_set_current_output_port
{
- SCM ooutp = scm_cur_outp;
+ SCM ooutp = scm_fluid_ref (cur_outport_fluid);
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port);
- scm_cur_outp = port;
+ scm_fluid_set_x (cur_outport_fluid, port);
return ooutp;
}
#undef FUNC_NAME
@@ -420,69 +426,47 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
"Set the current default error port to @var{port}.")
#define FUNC_NAME s_scm_set_current_error_port
{
- SCM oerrp = scm_cur_errp;
+ SCM oerrp = scm_fluid_ref (cur_errport_fluid);
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port);
- scm_cur_errp = port;
+ scm_fluid_set_x (cur_errport_fluid, port);
return oerrp;
}
#undef FUNC_NAME
-typedef struct {
- SCM value;
- SCM (*getter) (void);
- SCM (*setter) (SCM);
-} swap_data;
-
-static void
-swap_port (SCM scm_data)
-{
- swap_data *d = (swap_data *)SCM_MALLOCDATA (scm_data);
- SCM t;
-
- t = d->getter ();
- d->setter (d->value);
- d->value = t;
-}
-
-static void
-scm_frame_current_foo_port (SCM port,
- SCM (*getter) (void), SCM (*setter) (SCM))
-{
- SCM scm_data = scm_malloc_obj (sizeof (swap_data));
- swap_data *data = (swap_data *)SCM_MALLOCDATA (scm_data);
- data->value = port;
- data->getter = getter;
- data->setter = setter;
-
- scm_frame_rewind_handler_with_scm (swap_port, scm_data,
- SCM_F_WIND_EXPLICITLY);
- scm_frame_unwind_handler_with_scm (swap_port, scm_data,
- SCM_F_WIND_EXPLICITLY);
-}
-
void
scm_frame_current_input_port (SCM port)
+#define FUNC_NAME NULL
{
- scm_frame_current_foo_port (port,
- scm_current_input_port,
- scm_set_current_input_port);
+ SCM_VALIDATE_OPINPORT (1, port);
+ scm_frame_fluid (cur_inport_fluid, port);
}
+#undef FUNC_NAME
void
scm_frame_current_output_port (SCM port)
+#define FUNC_NAME NULL
{
- scm_frame_current_foo_port (port,
- scm_current_output_port,
- scm_set_current_output_port);
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_frame_fluid (cur_outport_fluid, port);
}
+#undef FUNC_NAME
void
scm_frame_current_error_port (SCM port)
+#define FUNC_NAME NULL
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_frame_fluid (cur_errport_fluid, port);
+}
+#undef FUNC_NAME
+
+void
+scm_i_frame_current_load_port (SCM port)
{
- scm_frame_current_foo_port (port,
- scm_current_error_port,
- scm_set_current_error_port);
+ scm_frame_fluid (cur_loadport_fluid, port);
}
@@ -493,7 +477,7 @@ scm_t_port **scm_i_port_table;
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);
+scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* This function is not and should not be thread safe. */
@@ -764,9 +748,9 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
rv = (scm_ptobs[i].close) (port);
else
rv = 0;
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
scm_remove_from_port_table (port);
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
SCM_CLR_PORT_OPEN_FLAG (port);
return scm_from_bool (rv >= 0);
}
@@ -815,18 +799,18 @@ scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
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_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
n = scm_i_port_table_size;
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ scm_i_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_i_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);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
for (i = 0; i < n; i++)
proc (data, SCM_SIMPLE_VECTOR_REF (ports, i));
@@ -919,7 +903,7 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
#define FUNC_NAME s_scm_force_output
{
if (SCM_UNBNDP (port))
- port = scm_cur_outp;
+ port = scm_current_output_port ();
else
{
port = SCM_COERCE_OUTPORT (port);
@@ -938,13 +922,13 @@ SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
{
size_t i;
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -958,7 +942,7 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
{
int c;
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
SCM_VALIDATE_OPINPORT (1, port);
c = scm_getc (port);
if (EOF == c)
@@ -1300,7 +1284,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
{
int c, column;
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
else
SCM_VALIDATE_OPINPORT (1, port);
column = SCM_COL(port);
@@ -1325,7 +1309,7 @@ SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0,
SCM_VALIDATE_CHAR (1, cobj);
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
else
SCM_VALIDATE_OPINPORT (2, port);
@@ -1346,7 +1330,7 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0,
{
SCM_VALIDATE_STRING (1, str);
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
else
SCM_VALIDATE_OPINPORT (2, port);
@@ -1638,7 +1622,7 @@ write_void_port (SCM port SCM_UNUSED,
static SCM
scm_i_void_port (long mode_bits)
{
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_i_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);
@@ -1647,7 +1631,7 @@ scm_i_void_port (long mode_bits)
SCM_SETSTREAM (answer, 0);
SCM_SET_CELL_TYPE (answer, scm_tc16_void_port | mode_bits);
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return answer;
}
}
@@ -1683,6 +1667,12 @@ scm_init_ports ()
scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port,
write_void_port);
+
+ cur_inport_fluid = scm_permanent_object (scm_make_fluid ());
+ cur_outport_fluid = scm_permanent_object (scm_make_fluid ());
+ cur_errport_fluid = scm_permanent_object (scm_make_fluid ());
+ cur_loadport_fluid = scm_permanent_object (scm_make_fluid ());
+
#include "libguile/ports.x"
}
diff --git a/libguile/ports.h b/libguile/ports.h
index 606aaa81c..9cf43884a 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -111,7 +111,7 @@ typedef struct
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 scm_i_pthread_mutex_t scm_i_port_table_mutex;
#define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end)
@@ -306,6 +306,7 @@ SCM_API SCM scm_pt_member (SCM member);
/* internal */
SCM_API long scm_i_mode_bits (SCM modes);
+SCM_API void scm_i_frame_current_load_port (SCM port);
#endif /* SCM_PORTS_H */
diff --git a/libguile/posix.c b/libguile/posix.c
index 2c37ae8ec..513dde81f 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -40,6 +40,7 @@
#include "libguile/validate.h"
#include "libguile/posix.h"
#include "libguile/i18n.h"
+#include "libguile/threads.h"
#ifdef HAVE_STRING_H
@@ -820,11 +821,11 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
return SCM_BOOL_F;
fd = SCM_FPORT_FDES (port);
- scm_mutex_lock (&scm_i_misc_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
if (!result)
{
@@ -1505,15 +1506,12 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0,
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_i_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));
diff --git a/libguile/print.c b/libguile/print.c
index be6b7c235..e00f01cd7 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -133,7 +133,7 @@ do { \
SCM scm_print_state_vtable = SCM_BOOL_F;
static SCM print_state_pool = SCM_EOL;
-SCM_MUTEX (print_state_mutex);
+scm_i_pthread_mutex_t print_state_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
#ifdef GUILE_DEBUG /* Used for debugging purposes */
@@ -173,13 +173,13 @@ scm_make_print_state ()
SCM answer = SCM_BOOL_F;
/* First try to allocate a print state from the pool */
- scm_i_plugin_mutex_lock (&print_state_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&print_state_mutex);
return scm_is_false (answer) ? make_print_state () : answer;
}
@@ -197,10 +197,10 @@ scm_free_print_state (SCM print_state)
pstate->fancyp = 0;
pstate->revealed = 0;
pstate->highlight_objects = SCM_EOL;
- scm_i_plugin_mutex_lock (&print_state_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&print_state_mutex);
}
SCM
@@ -692,13 +692,13 @@ scm_prin1 (SCM exp, SCM port, int writingp)
else
{
/* First try to allocate a print state from the pool */
- scm_i_plugin_mutex_lock (&print_state_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&print_state_mutex);
if (scm_is_false (handle))
handle = scm_list_1 (make_print_state ());
pstate_scm = SCM_CAR (handle);
@@ -715,10 +715,10 @@ scm_prin1 (SCM exp, SCM port, int writingp)
if (scm_is_true (handle) && !pstate->revealed)
{
- scm_i_plugin_mutex_lock (&print_state_mutex);
+ scm_i_pthread_mutex_lock (&print_state_mutex);
SCM_SETCDR (handle, print_state_pool);
print_state_pool = handle;
- scm_i_plugin_mutex_unlock (&print_state_mutex);
+ scm_i_pthread_mutex_unlock (&print_state_mutex);
}
}
@@ -878,7 +878,7 @@ SCM
scm_write (SCM obj, SCM port)
{
if (SCM_UNBNDP (port))
- port = scm_cur_outp;
+ port = scm_current_output_port ();
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
@@ -899,7 +899,7 @@ SCM
scm_display (SCM obj, SCM port)
{
if (SCM_UNBNDP (port))
- port = scm_cur_outp;
+ port = scm_current_output_port ();
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
@@ -938,7 +938,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
if (scm_is_eq (destination, SCM_BOOL_T))
{
- destination = port = scm_cur_outp;
+ destination = port = scm_current_output_port ();
}
else if (scm_is_false (destination))
{
@@ -1020,7 +1020,7 @@ SCM_DEFINE (scm_newline, "newline", 0, 1, 0,
#define FUNC_NAME s_scm_newline
{
if (SCM_UNBNDP (port))
- port = scm_cur_outp;
+ port = scm_current_output_port ();
SCM_VALIDATE_OPORT_VALUE (1, port);
@@ -1035,7 +1035,7 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
#define FUNC_NAME s_scm_write_char
{
if (SCM_UNBNDP (port))
- port = scm_cur_outp;
+ port = scm_current_output_port ();
SCM_VALIDATE_CHAR (1, chr);
SCM_VALIDATE_OPORT_VALUE (2, port);
diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h
index ee61096f5..811c15f11 100644
--- a/libguile/pthread-threads.h
+++ b/libguile/pthread-threads.h
@@ -1,9 +1,9 @@
/* classes: h_files */
-#ifndef SCM_THREADS_PTHREADS_H
-#define SCM_THREADS_PTHREADS_H
+#ifndef SCM_PTHREADS_THREADS_H
+#define SCM_PTHREADS_THREADS_H
-/* Copyright (C) 2002 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2005 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -25,58 +25,66 @@
/* The pthreads-threads implementation. This is a direct mapping.
*/
-/* This is an interface between Guile and the pthreads thread package. */
-
#include <pthread.h>
#include <sched.h>
-#include "libguile/threads-plugin.h"
-
-/* MDJ 021209 <djurfeldt@nada.kth.se>:
- The separation of the plugin interface and the low-level C API
- (currently in threads.h) needs to be completed in a sensible way.
+/* Threads
+*/
+#define scm_i_pthread_t pthread_t
+#define scm_i_pthread_self pthread_self
+#define scm_i_pthread_create pthread_create
+#define scm_i_pthread_detach pthread_detach
+#define scm_i_pthread_exit pthread_exit
+#define scm_i_sched_yield sched_yield
+
+/* Signals
*/
+#define scm_i_pthread_sigmask pthread_sigmask
-/* The scm_t_ types are temporarily used both in plugin and low-level API */
-#define scm_t_thread pthread_t
-
-#define scm_i_plugin_thread_create pthread_create
-
-#define scm_i_plugin_thread_join pthread_join
-#define scm_i_plugin_thread_detach pthread_detach
-#define scm_i_plugin_thread_self pthread_self
-#define scm_i_plugin_thread_yield sched_yield
-
-extern scm_t_mutexattr scm_i_plugin_mutex; /* The "fast" mutex. */
-
-#define scm_i_plugin_mutex_destroy(m) \
- pthread_mutex_destroy ((pthread_mutex_t *) (m))
-#define scm_i_plugin_mutex_trylock(m) \
- pthread_mutex_trylock ((pthread_mutex_t *) (m))
-
-extern scm_t_mutexattr scm_i_plugin_rec_mutex;
-
-#define scm_i_plugin_cond_init pthread_cond_init
-#define scm_i_plugin_cond_destroy pthread_cond_destroy
-#define scm_i_plugin_cond_signal pthread_cond_signal
-#define scm_i_plugin_cond_broadcast pthread_cond_broadcast
-
-#define scm_t_key pthread_key_t
-
-#define scm_i_plugin_key_create pthread_key_create
-#define scm_i_plugin_key_delete pthread_key_delete
-#define scm_i_plugin_setspecific pthread_setspecific
-#define scm_i_plugin_getspecific pthread_getspecific
-
-#define scm_i_plugin_select select
+/* Mutexes
+ */
+#define SCM_I_PTHREAD_MUTEX_INITIALIZER PTHREAD_MUTEX_INITIALIZER
+#define SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER \
+ PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP
+#define scm_i_pthread_mutex_t pthread_mutex_t
+#define scm_i_pthread_mutex_init pthread_mutex_init
+#define scm_i_pthread_mutex_destroy pthread_mutex_destroy
+#define scm_i_pthread_mutex_trylock pthread_mutex_trylock
+#define scm_i_pthread_mutex_lock pthread_mutex_lock
+#define scm_i_pthread_mutex_unlock pthread_mutex_unlock
+
+/* Condition variables
+ */
+#define SCM_I_PTHREAD_COND_INITIALIZER PTHREAD_COND_INITIALIZER
+#define scm_i_pthread_cond_t pthread_cond_t
+#define scm_i_pthread_cond_init pthread_cond_init
+#define scm_i_pthread_cond_destroy pthread_cond_destroy
+#define scm_i_pthread_cond_signal pthread_cond_signal
+#define scm_i_pthread_cond_broadcast pthread_cond_broadcast
+#define scm_i_pthread_cond_wait pthread_cond_wait
+#define scm_i_pthread_cond_timedwait pthread_cond_timedwait
+
+/* Onces
+ */
+#define scm_i_pthread_once_t pthread_once_t
+#define SCM_I_PTHREAD_ONCE_INIT PTHREAD_ONCE_INIT
+#define scm_i_pthread_once pthread_once
-#ifdef SCM_DEBUG_THREADS
-void scm_i_assert_heap_locked (void);
-#endif
+/* Thread specific storage
+ */
+#define scm_i_pthread_key_t pthread_key_t
+#define scm_i_pthread_key_create pthread_key_create
+#define scm_i_pthread_setspecific pthread_setspecific
+#define scm_i_pthread_getspecific pthread_getspecific
-void scm_init_pthread_threads (void);
+/* Convenience functions
+ */
+#define scm_i_scm_pthread_mutex_lock scm_pthread_mutex_lock
+#define scm_i_frame_pthread_mutex_lock scm_frame_pthread_mutex_lock
+#define scm_i_scm_pthread_cond_wait scm_pthread_cond_wait
+#define scm_i_scm_pthread_cond_timedwait scm_pthread_cond_timedwait
-#endif /* SCM_THREADS_PTHREADS_H */
+#endif /* SCM_PTHREADS_THREADS_H */
/*
Local Variables:
diff --git a/libguile/rdelim.c b/libguile/rdelim.c
index 98e88779e..656ca1680 100644
--- a/libguile/rdelim.c
+++ b/libguile/rdelim.c
@@ -71,7 +71,7 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0,
start, &cstart, end, &cend);
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
else
SCM_VALIDATE_OPINPORT (4, port);
@@ -208,7 +208,7 @@ SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0,
SCM line, term;
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
SCM_VALIDATE_OPINPORT (1,port);
pt = SCM_PTAB_ENTRY (port);
diff --git a/libguile/read.c b/libguile/read.c
index f2913f915..756efa6ec 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -134,7 +134,7 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0,
SCM tok_buf, copy;
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_current_input_port ();
SCM_VALIDATE_OPINPORT (1, port);
c = scm_flush_ws (port, (char *) NULL);
diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c
index 0c51280ed..f17dd3049 100644
--- a/libguile/regex-posix.c
+++ b/libguile/regex-posix.c
@@ -243,7 +243,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
whole regexp, so add 1 to nmatches. */
nmatches = SCM_RGX(rx)->re_nsub + 1;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
matches = scm_malloc (sizeof (regmatch_t) * nmatches);
c_str = scm_to_locale_string (substr);
status = regexec (SCM_RGX (rx), c_str, nmatches, matches,
@@ -267,7 +267,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
scm_from_long (matches[i].rm_eo + offset)));
}
free (matches);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
if (status != 0 && status != REG_NOMATCH)
scm_error_scm (scm_regexp_error_key,
diff --git a/libguile/root.c b/libguile/root.c
index dfe0ae313..07209c95c 100644
--- a/libguile/root.c
+++ b/libguile/root.c
@@ -19,6 +19,8 @@
#include <string.h>
+#include <stdio.h>
+
#include "libguile/_scm.h"
#include "libguile/stackchk.h"
#include "libguile/dynwind.h"
@@ -34,89 +36,8 @@
SCM scm_sys_protects[SCM_NUM_PROTECTS];
-scm_t_bits scm_tc16_root;
-
-
-
-static SCM
-root_mark (SCM root)
-{
- scm_root_state *s = SCM_ROOT_STATE (root);
-
- 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);
- /* No need to gc mark def_loadp */
- scm_gc_mark (s->fluids);
- scm_gc_mark (s->active_asyncs);
- scm_gc_mark (s->signal_asyncs);
- return SCM_ROOT_STATE (root) -> parent;
-}
-
-
-static int
-root_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts ("#<root ", port);
- scm_uintprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
- scm_putc('>', port);
- return 1;
-}
-
-
-SCM
-scm_make_root (SCM parent)
-{
- SCM root;
- scm_root_state *root_state;
-
- root_state = (scm_root_state *) scm_gc_malloc (sizeof (scm_root_state),
- "root state");
- if (SCM_ROOTP (parent))
- {
- memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
- root_state->parent = parent;
- }
- else
- {
- root_state->parent = SCM_BOOL_F;
-
- /* Initialize everything right now, in case a GC happens early. */
- root_state->rootcont
- = root_state->dynwinds
- = root_state->progargs
- = root_state->exitval
- = root_state->cur_inp
- = root_state->cur_outp
- = root_state->cur_errp
- = root_state->cur_loadp
- = root_state->fluids
- = root_state->handle
- = root_state->parent
- = SCM_BOOL_F;
- }
-
- root_state->active_asyncs = SCM_EOL;
- root_state->signal_asyncs = SCM_EOL;
- root_state->block_asyncs = 0;
- root_state->pending_asyncs = 1;
-
- SCM_NEWSMOB (root, scm_tc16_root, root_state);
- root_state->handle = root;
-
- if (SCM_ROOTP (parent))
- /* Must be done here so that fluids are GC protected */
- scm_i_copy_fluids (root_state);
-
- return root;
-}
-
/* {call-with-dynamic-root}
*
* Suspending the current thread to evaluate a thunk on the
@@ -125,25 +46,6 @@ scm_make_root (SCM parent)
* Calls to call-with-dynamic-root return exactly once (unless
* the process is somehow exitted). */
-/* Some questions about cwdr:
-
- Couldn't the body just be a closure? Do we really need to pass
- args through to it?
-
- The semantics are a lot like catch's; in fact, we call
- scm_internal_catch to take care of that part of things. Wouldn't
- it be cleaner to say that uncaught throws just disappear into the
- ether (or print a message to stderr), and let the caller use catch
- themselves if they want to?
-
- -JimB */
-
-#if 0
-SCM scm_exitval; /* INUM with return value */
-#endif
-static long n_dynamic_roots = 0;
-
-
/* cwdr fills out both of these structures, and then passes a pointer
to them through scm_internal_catch to the cwdr_body and
cwdr_handler functions, to tell them how to behave and to get
@@ -201,62 +103,31 @@ cwdr_handler (void *data, SCM tag, SCM args)
return SCM_UNSPECIFIED;
}
-/* This is the basic code for new root creation.
- *
- * WARNING! The order of actions in this routine is in many ways
- * critical. E. g., it is essential that an error doesn't leave Guile
- * in a messed up state. */
-
SCM
scm_internal_cwdr (scm_t_catch_body body, void *body_data,
scm_t_catch_handler handler, void *handler_data,
SCM_STACKITEM *stack_start)
{
- SCM old_rootcont, old_winds;
struct cwdr_handler_data my_handler_data;
- SCM answer;
-
- /* Create a fresh root continuation. */
- {
- SCM new_rootcont;
-
- SCM_REDEFER_INTS;
- {
- scm_t_contregs *contregs = scm_gc_malloc (sizeof (scm_t_contregs),
- "continuation");
-
- contregs->num_stack_items = 0;
- contregs->dynenv = SCM_EOL;
- contregs->base = stack_start;
- contregs->seq = ++n_dynamic_roots;
- contregs->throw_value = SCM_BOOL_F;
- contregs->dframe = 0;
- SCM_NEWSMOB (new_rootcont, scm_tc16_continuation, contregs);
- }
- old_rootcont = scm_rootcont;
- scm_rootcont = new_rootcont;
- SCM_REALLOW_INTS;
- }
+ SCM answer, old_winds;
/* Exit caller's dynamic state.
*/
- old_winds = scm_dynwinds;
- scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
- SCM_DFRAME (old_rootcont) = scm_last_debug_frame;
- scm_last_debug_frame = 0;
-
- {
- my_handler_data.run_handler = 0;
- answer = scm_internal_catch (SCM_BOOL_T,
- body, body_data,
- cwdr_handler, &my_handler_data);
- }
+ old_winds = scm_i_dynwinds ();
+ scm_dowinds (SCM_EOL, scm_ilength (old_winds));
+
+ scm_frame_begin (SCM_F_FRAME_REWINDABLE);
+ scm_frame_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED));
+ my_handler_data.run_handler = 0;
+ answer = scm_i_with_continuation_barrier (body, body_data,
+ cwdr_handler, &my_handler_data);
+
+ scm_frame_end ();
+
+ /* Enter caller's dynamic state.
+ */
scm_dowinds (old_winds, - scm_ilength (old_winds));
- SCM_REDEFER_INTS;
- scm_last_debug_frame = SCM_DFRAME (old_rootcont);
- scm_rootcont = old_rootcont;
- SCM_REALLOW_INTS;
/* Now run the real handler iff the body did a throw. */
if (my_handler_data.run_handler)
@@ -328,12 +199,10 @@ SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
(),
"Return an object representing the current dynamic root.\n\n"
- "These objects are only useful for comparison using @code{eq?}.\n"
- "They are currently represented as numbers, but your code should\n"
- "in no way depend on this.")
+ "These objects are only useful for comparison using @code{eq?}.\n")
#define FUNC_NAME s_scm_dynamic_root
{
- return scm_from_ulong (SCM_SEQ (scm_root->rootcont));
+ return SCM_I_CURRENT_THREAD->continuation_root;
}
#undef FUNC_NAME
@@ -349,10 +218,6 @@ scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
void
scm_init_root ()
{
- scm_tc16_root = scm_make_smob_type ("root", sizeof (struct scm_root_state));
- scm_set_smob_mark (scm_tc16_root, root_mark);
- scm_set_smob_print (scm_tc16_root, root_print);
-
#include "libguile/root.x"
}
diff --git a/libguile/root.h b/libguile/root.h
index a97cf7536..b23b03dd5 100644
--- a/libguile/root.h
+++ b/libguile/root.h
@@ -47,66 +47,6 @@ SCM_API SCM scm_sys_protects[];
-SCM_API scm_t_bits scm_tc16_root;
-
-#define SCM_ROOTP(obj) SCM_SMOB_PREDICATE (scm_tc16_root, (obj))
-#define SCM_ROOT_STATE(root) ((scm_root_state *) SCM_SMOB_DATA (root))
-
-typedef struct scm_root_state
-{
- SCM_STACKITEM * stack_base;
- jmp_buf save_regs_gc_mark;
- int errjmp_bad;
-
- SCM rootcont;
- SCM dynwinds;
-
- /* 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 cur_inp;
- SCM cur_outp;
- SCM cur_errp;
- SCM cur_loadp;
-
- SCM fluids;
-
- SCM handle; /* The root object for this root state */
- SCM parent; /* The parent root object */
-
- SCM active_asyncs; /* The thunks to be run at the next
- safe point */
- SCM signal_asyncs; /* The pre-queued cells for signal handlers.
- */
- unsigned int block_asyncs; /* Non-zero means that asyncs should
- not be run. */
- unsigned int pending_asyncs; /* Non-zero means that asyncs might be pending.
- */
-} scm_root_state;
-
-#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_rootcont (scm_root->rootcont)
-#define scm_dynwinds (scm_root->dynwinds)
-#define scm_progargs (scm_root->progargs)
-#define scm_last_debug_frame (scm_root->last_debug_frame)
-#define scm_exitval (scm_root->exitval)
-#define scm_cur_inp (scm_root->cur_inp)
-#define scm_cur_outp (scm_root->cur_outp)
-#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)
-
-
-
-SCM_API SCM scm_make_root (SCM parent);
SCM_API SCM scm_internal_cwdr (scm_t_catch_body body,
void *body_data,
scm_t_catch_handler handler,
diff --git a/libguile/rw.c b/libguile/rw.c
index 49123b59f..ce267c186 100644
--- a/libguile/rw.c
+++ b/libguile/rw.c
@@ -120,7 +120,8 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
fdes = scm_to_int (port_or_fdes);
else
{
- SCM port = SCM_UNBNDP (port_or_fdes) ? scm_cur_inp : port_or_fdes;
+ SCM port = (SCM_UNBNDP (port_or_fdes)?
+ scm_current_input_port () : port_or_fdes);
SCM_VALIDATE_OPFPORT (2, port);
SCM_VALIDATE_INPUT_PORT (2, port);
@@ -227,7 +228,8 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
fdes = scm_to_int (port_or_fdes);
else
{
- SCM port = SCM_UNBNDP (port_or_fdes) ? scm_cur_outp : port_or_fdes;
+ SCM port = (SCM_UNBNDP (port_or_fdes)?
+ scm_current_output_port () : port_or_fdes);
scm_t_port *pt;
off_t space;
diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c
index 618506ea7..5ed5091ac 100644
--- a/libguile/scmsigs.c
+++ b/libguile/scmsigs.c
@@ -23,6 +23,7 @@
#endif
#include <signal.h>
+#include <stdio.h>
#include <errno.h>
#include "libguile/_scm.h"
@@ -69,21 +70,24 @@
/* take_signal is installed as the C signal handler whenever a Scheme
- handler is set. when a signal arrives, take_signal will queue the
- Scheme handler procedure for its thread. */
+ handler is set. When a signal arrives, take_signal will write a
+ byte into the 'signal pipe'. The 'signal delivery thread' will
+ read this pipe and queue the appropriate asyncs.
+
+ When Guile is built without threads, the signal handler will
+ install the async directly.
+*/
/* Scheme vectors with information about a signal. signal_handlers
- contains the handler procedure or #f, signal_handler_cells contains
- pre-queued cells for the handler (since we can't do fancy things
- during signal delivery), signal_cell_handlers contains the SCM
- value to be stuffed into the pre-queued cell upon delivery, and
+ contains the handler procedure or #f, signal_handler_asyncs
+ contains the thunk to be marked as an async when the signal arrives
+ (or the cell with the thunk in a singlethreaded Guile), and
signal_handler_threads points to the thread that a signal should be
delivered to.
*/
static SCM *signal_handlers;
-static SCM signal_handler_cells;
-static SCM signal_cell_handlers;
+static SCM signal_handler_asyncs;
static SCM signal_handler_threads;
/* saves the original C handlers, when a new handler is installed.
@@ -94,164 +98,128 @@ static struct sigaction orig_handlers[NSIG];
static SIGRETTYPE (*orig_handlers[NSIG])(int);
#endif
+static SCM
+close_1 (SCM proc, SCM arg)
+{
+ return scm_primitive_eval_x (scm_list_3 (scm_sym_lambda, SCM_EOL,
+ scm_list_2 (proc, arg)));
+}
+
+#if SCM_USE_PTHREAD_THREADS
+
+static int signal_pipe[2];
static SIGRETTYPE
take_signal (int signum)
{
- if (signum >= 0 && signum < NSIG)
- {
- SCM cell = SCM_SIMPLE_VECTOR_REF (signal_handler_cells, signum);
- SCM handler = SCM_SIMPLE_VECTOR_REF (signal_cell_handlers, signum);
- SCM thread = SCM_SIMPLE_VECTOR_REF (signal_handler_threads, signum);
- scm_root_state *root = scm_i_thread_root (thread);
- if (scm_is_pair (cell))
- {
- SCM_SETCAR (cell, handler);
- root->pending_asyncs = 1;
- }
- }
-
+ char sigbyte = signum;
+ write (signal_pipe[1], &sigbyte, 1);
+
#ifndef HAVE_SIGACTION
signal (signum, take_signal);
#endif
}
-SCM
-scm_sigaction (SCM signum, SCM handler, SCM flags)
+static SCM
+signal_delivery_thread (void *data)
{
- return scm_sigaction_for_thread (signum, handler, flags, SCM_UNDEFINED);
+ sigset_t all_sigs;
+ scm_t_guile_ticket ticket;
+ int n, sig;
+ char sigbyte;
+
+ sigfillset (&all_sigs);
+ scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
+
+ while (1)
+ {
+ ticket = scm_leave_guile ();
+ n = read (signal_pipe[0], &sigbyte, 1);
+ sig = sigbyte;
+ scm_enter_guile (ticket);
+ if (n == 1 && sig >= 0 && sig < NSIG)
+ {
+ SCM h, t;
+
+ h = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, sig);
+ t = SCM_SIMPLE_VECTOR_REF (signal_handler_threads, sig);
+ if (scm_is_true (h))
+ scm_system_async_mark_for_thread (h, t);
+ }
+ else if (n < 0 && errno != EINTR)
+ perror ("error in signal delivery thread");
+ }
}
-static SCM
-close_1 (SCM proc, SCM arg)
+static void
+start_signal_delivery_thread (void)
{
- return scm_primitive_eval_x (scm_list_3 (scm_sym_lambda, SCM_EOL,
- scm_list_2 (proc, arg)));
+ if (pipe (signal_pipe) != 0)
+ scm_syserror (NULL);
+ scm_spawn_thread (signal_delivery_thread, NULL,
+ scm_handle_by_message, "signal delivery thread");
}
-/* Make sure that signal SIGNUM can be delivered to THREAD, using
- HANDLER. THREAD and HANDLER must either both be non-#f (which
- means install the handler), or both #f (which means deinstall an
- existing handler).
-*/
+static void
+ensure_signal_delivery_thread ()
+{
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, start_signal_delivery_thread);
+}
-struct install_handler_data {
- int signum;
- SCM thread;
- SCM handler;
-};
+#else /* !SCM_USE_PTHREAD_THREADS */
-static SCM
-scm_delq_spine_x (SCM cell, SCM list)
+static SIGRETTYPE
+take_signal (int signum)
{
- SCM s = list, prev = SCM_BOOL_F;
-
- while (!scm_is_eq (cell, s))
- {
- if (scm_is_null (s))
- return list;
- prev = s;
- s = SCM_CDR (s);
- }
- if (scm_is_false (prev))
- return SCM_CDR (cell);
- else
+ SCM cell = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, signum);
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ if (scm_is_false (SCM_CDR (cell)))
{
- SCM_SETCDR (prev, SCM_CDR (cell));
- return list;
+ SCM_SETCDR (cell, t->active_asyncs);
+ t->active_asyncs = cell;
+ t->pending_asyncs = 1;
}
+
+#ifndef HAVE_SIGACTION
+ signal (signum, take_signal);
+#endif
}
-static void *
-really_install_handler (void *data)
+static void
+ensure_signal_delivery_thread ()
{
- struct install_handler_data *args = data;
- int signum = args->signum;
- SCM thread = args->thread;
- SCM handler = args->handler;
- SCM cell;
- SCM old_thread;
-
- /* The following modifications are done while signals can be
- delivered. That is not a real problem since the signal handler
- will only touch the car of the handler cell and set the
- pending_asyncs trigger of a thread. While the data structures
- are in flux, the signal handler might store the wrong handler in
- the cell, or set pending_asyncs of the wrong thread. We fix this
- at the end by making sure that the cell has the right handler in
- it, if any, and that pending_asyncs is set for the new thread.
- */
-
- /* Make sure we have a cell. */
- cell = SCM_SIMPLE_VECTOR_REF (signal_handler_cells, signum);
- if (scm_is_false (cell))
- {
- cell = scm_cons (SCM_BOOL_F, SCM_EOL);
- SCM_SIMPLE_VECTOR_SET (signal_handler_cells, signum, cell);
- }
+ return;
+}
- /* Make sure it is queued for the right thread. */
- old_thread = SCM_SIMPLE_VECTOR_REF (signal_handler_threads, signum);
- if (!scm_is_eq (thread, old_thread))
- {
- scm_root_state *r;
- if (scm_is_true (old_thread))
- {
- r = scm_i_thread_root (old_thread);
- r->signal_asyncs = scm_delq_spine_x (cell, r->signal_asyncs);
- }
- if (scm_is_true (thread))
- {
- r = scm_i_thread_root (thread);
- SCM_SETCDR (cell, r->signal_asyncs);
- r->signal_asyncs = cell;
- /* Set pending_asyncs just in case. A signal that is
- delivered while we modify the data structures here might set
- pending_asyncs of old_thread. */
- r->pending_asyncs = 1;
- }
- SCM_SIMPLE_VECTOR_SET (signal_handler_threads, signum, thread);
- }
+#endif /* !SCM_USE_PTHREAD_THREADS */
- /* Set the new handler. */
+static void
+install_handler (int signum, SCM thread, SCM handler)
+{
if (scm_is_false (handler))
{
SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, SCM_BOOL_F);
- SCM_SIMPLE_VECTOR_SET (signal_cell_handlers, signum, SCM_BOOL_F);
+ SCM_SIMPLE_VECTOR_SET (signal_handler_asyncs, signum, SCM_BOOL_F);
}
else
{
+ SCM async = close_1 (handler, scm_from_int (signum));
+#if !SCM_USE_PTHREAD_THREADS
+ async = scm_cons (async, SCM_BOOL_F);
+#endif
SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, handler);
- SCM_SIMPLE_VECTOR_SET (signal_cell_handlers, signum,
- close_1 (handler, scm_from_int (signum)));
+ SCM_SIMPLE_VECTOR_SET (signal_handler_asyncs, signum, async);
}
- /* Now fix up the cell. It might contain the old handler but since
- it is now queued for the new thread, we must make sure that the
- new handler is run. Any signal that is delivered during the
- following code will install the new handler, so we have no
- problem.
- */
- if (scm_is_true (SCM_CAR (cell)))
- SCM_SETCAR (cell, SCM_SIMPLE_VECTOR_REF (signal_cell_handlers, signum));
-
- /* Phfew. That should be it. */
- return NULL;
+ SCM_SIMPLE_VECTOR_SET (signal_handler_threads, signum, thread);
}
-static void
-install_handler (int signum, SCM thread, SCM handler)
+SCM
+scm_sigaction (SCM signum, SCM handler, SCM flags)
{
- /* We block asyncs while installing the handler. It would be safe
- to leave them on, but we might run the wrong handler should a
- signal be delivered.
- */
-
- struct install_handler_data args;
- args.signum = signum;
- args.thread = thread;
- args.handler = handler;
- scm_c_call_with_blocked_asyncs (really_install_handler, &args);
+ return scm_sigaction_for_thread (signum, handler, flags, SCM_UNDEFINED);
}
/* user interface for installation of signal handlers. */
@@ -323,19 +291,22 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
}
- SCM_DEFER_INTS;
+ ensure_signal_delivery_thread ();
+
+ SCM_CRITICAL_SECTION_START;
old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig);
if (SCM_UNBNDP (handler))
query_only = 1;
else if (scm_is_integer (handler))
{
- if (SCM_NUM2LONG (2, handler) == (long) SIG_DFL
- || SCM_NUM2LONG (2, handler) == (long) SIG_IGN)
+ long handler_int = scm_to_long (handler);
+
+ if (handler_int == (long) SIG_DFL || handler_int == (long) SIG_IGN)
{
#ifdef HAVE_SIGACTION
- action.sa_handler = (SIGRETTYPE (*) (int)) scm_to_long (handler);
+ action.sa_handler = (SIGRETTYPE (*) (int)) handler_int;
#else
- chandler = (SIGRETTYPE (*) (int)) scm_to_int (handler);
+ chandler = (SIGRETTYPE (*) (int)) handler_int;
#endif
install_handler (csig, SCM_BOOL_F, SCM_BOOL_F);
}
@@ -425,7 +396,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
}
if (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN)
old_handler = scm_from_long ((long) old_action.sa_handler);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return scm_cons (old_handler, scm_from_int (old_action.sa_flags));
#else
if (query_only)
@@ -444,7 +415,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
}
if (old_chandler == SIG_DFL || old_chandler == SIG_IGN)
old_handler = scm_from_long ((long) old_chandler);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return scm_cons (old_handler, scm_from_int (0));
#endif
}
@@ -601,7 +572,7 @@ SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0,
"of seconds remaining otherwise.")
#define FUNC_NAME s_scm_sleep
{
- return scm_from_ulong (scm_thread_sleep (scm_to_int (i)));
+ return scm_from_uint (scm_std_sleep (scm_to_uint (i)));
}
#undef FUNC_NAME
@@ -610,7 +581,7 @@ SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0,
"Sleep for @var{i} microseconds.")
#define FUNC_NAME s_scm_usleep
{
- return scm_from_ulong (scm_thread_usleep (scm_to_ulong (i)));
+ return scm_from_ulong (scm_std_usleep (scm_to_ulong (i)));
}
#undef FUNC_NAME
@@ -636,9 +607,7 @@ scm_init_scmsigs ()
signal_handlers =
SCM_VARIABLE_LOC (scm_c_define ("signal-handlers",
scm_c_make_vector (NSIG, SCM_BOOL_F)));
- signal_handler_cells =
- scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
- signal_cell_handlers =
+ signal_handler_asyncs =
scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
signal_handler_threads =
scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
diff --git a/libguile/smob.c b/libguile/smob.c
index 798fb5f7b..8ad641992 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -290,11 +290,11 @@ scm_make_smob_type (char const *name, size_t size)
{
long new_smob;
- SCM_ENTER_A_SECTION; /* scm_numsmob */
+ SCM_CRITICAL_SECTION_START;
new_smob = scm_numsmob;
if (scm_numsmob != MAX_SMOB_COUNT)
++scm_numsmob;
- SCM_EXIT_A_SECTION;
+ SCM_CRITICAL_SECTION_END;
if (new_smob == MAX_SMOB_COUNT)
scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index 9851b747b..1aed54d41 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -102,7 +102,7 @@ SCM
scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist)
{
register scm_t_srcprops *ptr;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
if ((ptr = srcprops_freelist) != NULL)
srcprops_freelist = *(scm_t_srcprops **)ptr;
else
@@ -128,7 +128,7 @@ scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist)
ptr->fname = filename;
ptr->copy = copy;
ptr->plist = plist;
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr);
}
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index 53da9f86f..dfc4ec777 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -853,7 +853,7 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
void *base;
if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_cur_inp;
+ port_or_fd = scm_current_input_port ();
else
SCM_ASSERT (scm_is_integer (port_or_fd)
|| (SCM_OPINPORTP (port_or_fd)),
@@ -968,7 +968,7 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_cur_outp;
+ port_or_fd = scm_current_output_port ();
else
SCM_ASSERT (scm_is_integer (port_or_fd)
|| (SCM_OPOUTPORTP (port_or_fd)),
diff --git a/libguile/stackchk.c b/libguile/stackchk.c
index eaedd1c26..4382d871c 100644
--- a/libguile/stackchk.c
+++ b/libguile/stackchk.c
@@ -61,19 +61,20 @@ scm_stack_size (SCM_STACKITEM *start)
void
scm_stack_report ()
{
+ SCM port = scm_current_error_port ();
SCM_STACKITEM stack;
- scm_uintprint (scm_stack_size (SCM_BASE (scm_rootcont)) * sizeof (SCM_STACKITEM),
- 16, scm_cur_errp);
- scm_puts (" of stack: 0x", scm_cur_errp);
- scm_uintprint ((scm_t_bits) SCM_BASE (scm_rootcont), 16, scm_cur_errp);
- scm_puts (" - 0x", scm_cur_errp);
- scm_uintprint ((scm_t_bits) &stack, 16, scm_cur_errp);
- scm_puts ("\n", scm_cur_errp);
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+
+ scm_uintprint ((scm_stack_size (thread->continuation_base)
+ * sizeof (SCM_STACKITEM)),
+ 16, port);
+ scm_puts (" of stack: 0x", port);
+ scm_uintprint ((scm_t_bits) thread->continuation_base, 16, port);
+ scm_puts (" - 0x", port);
+ scm_uintprint ((scm_t_bits) &stack, 16, port);
+ scm_puts ("\n", port);
}
-
-
-
void
scm_init_stackchk ()
{
diff --git a/libguile/stackchk.h b/libguile/stackchk.h
index 938794114..4bf6e4163 100644
--- a/libguile/stackchk.h
+++ b/libguile/stackchk.h
@@ -37,11 +37,11 @@
# if SCM_STACK_GROWS_UP
# define SCM_STACK_OVERFLOW_P(s)\
(SCM_STACK_PTR (s) \
- > ((SCM_STACKITEM *) SCM_BASE (scm_rootcont) + SCM_STACK_LIMIT))
+ > (SCM_I_CURRENT_THREAD->base + SCM_STACK_LIMIT))
# else
# define SCM_STACK_OVERFLOW_P(s)\
(SCM_STACK_PTR (s) \
- < ((SCM_STACKITEM *) SCM_BASE (scm_rootcont) - SCM_STACK_LIMIT))
+ < (SCM_I_CURRENT_THREAD->base - SCM_STACK_LIMIT))
# endif
# define SCM_CHECK_STACK\
{\
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 9a38ff0f9..6f03442fb 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -434,7 +434,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
scm_make_stack was given. */
if (scm_is_eq (obj, SCM_BOOL_T))
{
- dframe = scm_last_debug_frame;
+ dframe = scm_i_last_debug_frame ();
}
else if (SCM_DEBUGOBJP (obj))
{
@@ -515,7 +515,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
long offset = 0;
if (scm_is_eq (stack, SCM_BOOL_T))
{
- dframe = scm_last_debug_frame;
+ dframe = scm_i_last_debug_frame ();
}
else if (SCM_DEBUGOBJP (stack))
{
diff --git a/libguile/stime.c b/libguile/stime.c
index 09e7772ff..b44b2d0cb 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -230,9 +230,9 @@ SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0,
{
timet timv;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
timv = time (NULL);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
if (timv == -1)
SCM_MISC_ERROR ("current time not available", SCM_EOL);
return scm_from_long (timv);
@@ -251,10 +251,10 @@ SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
struct timeval time;
int ret, err;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
ret = gettimeofday (&time, NULL);
err = errno;
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
if (ret == -1)
{
errno = err;
@@ -273,10 +273,10 @@ SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
timet timv;
int err;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
timv = time (NULL);
err = errno;
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
if (timv == -1)
{
errno = err;
@@ -375,7 +375,7 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
/* deferring interupts is essential since a) setzone may install a temporary
environment b) localtime uses a static buffer. */
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
#ifdef LOCALTIME_CACHE
tzset ();
@@ -428,7 +428,7 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
zoff += 24 * 60 * 60;
result = filltime (&lt, zoff, zname);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
if (zname)
free (zname);
return result;
@@ -461,11 +461,11 @@ SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
#if HAVE_GMTIME_R
bd_time = gmtime_r (&itime, &bd_buf);
#else
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
bd_time = gmtime (&itime);
if (bd_time != NULL)
bd_buf = *bd_time;
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
#endif
if (bd_time == NULL)
SCM_SYSERROR;
@@ -531,7 +531,7 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
scm_frame_free ((char *)lt.tm_zone);
#endif
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
#ifdef LOCALTIME_CACHE
tzset ();
@@ -584,7 +584,7 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
result = scm_cons (scm_from_long (itime),
filltime (&lt, zoff, zname));
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
if (zname)
free (zname);
@@ -667,7 +667,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
SCM_EOL)));
have_zone = 1;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
}
#endif
@@ -690,7 +690,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
if (have_zone)
{
restorezone (velts[10], oldenv, FUNC_NAME);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
}
#endif
}
@@ -743,11 +743,11 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
/* GNU glibc strptime() "%s" is affected by the current timezone, since it
reads a UTC time_t value and converts with localtime_r() to set the tm
- fields, hence the use of SCM_DEFER_INTS. */
+ fields, hence the use of SCM_CRITICAL_SECTION_START. */
t.tm_isdst = -1;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
rest = strptime (str, fmt, &t);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
if (rest == NULL)
{
/* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
diff --git a/libguile/strings.c b/libguile/strings.c
index 8560a583e..addd1975b 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -136,7 +136,7 @@ scm_i_stringbuf_free (SCM buf)
STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
}
-SCM_MUTEX (stringbuf_write_mutex);
+scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* Copy-on-write strings.
*/
@@ -209,9 +209,9 @@ scm_i_substring (SCM str, size_t start, size_t end)
SCM buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ scm_i_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);
@@ -223,9 +223,9 @@ scm_i_substring_read_only (SCM str, size_t start, size_t end)
SCM buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ scm_i_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);
@@ -334,7 +334,7 @@ scm_i_string_writable_chars (SCM orig_str)
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);
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
if (STRINGBUF_SHARED (buf))
{
/* Clone stringbuf. For this, we put all threads to sleep.
@@ -343,7 +343,7 @@ scm_i_string_writable_chars (SCM orig_str)
size_t len = STRING_LENGTH (str);
SCM new_buf;
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
new_buf = make_stringbuf (len);
memcpy (STRINGBUF_CHARS (new_buf),
@@ -357,7 +357,7 @@ scm_i_string_writable_chars (SCM orig_str)
buf = new_buf;
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
}
return STRINGBUF_CHARS (buf) + start;
@@ -366,7 +366,7 @@ scm_i_string_writable_chars (SCM orig_str)
void
scm_i_string_stop_writing (void)
{
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
}
/* Symbols.
@@ -396,9 +396,9 @@ scm_i_make_symbol (SCM name, scm_t_bits flags,
if (start == 0 && length == STRINGBUF_LENGTH (buf))
{
/* reuse buf. */
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
}
else
{
@@ -441,9 +441,9 @@ SCM
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);
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
(scm_t_bits)start, (scm_t_bits) end - start);
}
diff --git a/libguile/strports.c b/libguile/strports.c
index f7b4013b8..9eef15e1e 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -288,7 +288,7 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
else
str = scm_c_substring (str, 0, str_len);
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_i_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));
@@ -301,7 +301,7 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
pt->rw_random = 1;
- scm_mutex_unlock (&scm_i_port_table_mutex);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
/* ensure write_pos is writable. */
if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
diff --git a/libguile/struct.c b/libguile/struct.c
index 44bdd5131..f54a77c38 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -429,7 +429,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]);
basic_size = scm_i_symbol_length (layout) / 2;
tail_elts = scm_to_size_t (tail_array_size);
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
{
data = scm_alloc_struct (basic_size + tail_elts,
@@ -446,7 +446,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
+ scm_tc3_struct),
(scm_t_bits) data, 0, 0);
scm_struct_init (handle, layout, data, tail_elts, init);
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return handle;
}
#undef FUNC_NAME
@@ -516,7 +516,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
layout = scm_make_struct_layout (fields);
basic_size = scm_i_symbol_length (layout) / 2;
tail_elts = scm_to_size_t (tail_array_size);
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
data = scm_alloc_struct (basic_size + tail_elts,
scm_struct_n_extra_words,
"struct");
@@ -524,7 +524,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
(scm_t_bits) data, 0, 0);
data [scm_vtable_index_layout] = SCM_UNPACK (layout);
scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init));
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return handle;
}
#undef FUNC_NAME
diff --git a/libguile/symbols.c b/libguile/symbols.c
index 204bc7446..f9f6180d3 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -279,9 +279,9 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
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_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
n = gensym_counter++;
- scm_mutex_unlock (&scm_i_misc_mutex);
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
n_digits = scm_iint2str (n, 10, buf);
suffix = scm_from_locale_stringn (buf, n_digits);
diff --git a/libguile/threads.c b/libguile/threads.c
index b772b84ba..c2c2ab55d 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -18,9 +18,7 @@
-/* This file implements nice Scheme level threads on top of the gastly
- C level threads.
-*/
+#define _GNU_SOURCE
#include "libguile/_scm.h"
@@ -41,15 +39,23 @@
#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 */
+/* Make an empty queue data structure.
+ */
static SCM
make_queue ()
{
return scm_cons (SCM_EOL, SCM_EOL);
}
+/* Put T at the back of Q and return a handle that can be used with
+ remqueue to remove T from Q again.
+ */
static SCM
enqueue (SCM q, SCM t)
{
@@ -62,7 +68,12 @@ enqueue (SCM q, SCM t)
return c;
}
-static void
+/* Remove the element that the handle C refers to from the queue Q. C
+ must have been returned from a call to enqueue. The return value
+ is zero when the element referred to by C has already been removed.
+ Otherwise, 1 is returned.
+*/
+static int
remqueue (SCM q, SCM c)
{
SCM p, prev = q;
@@ -73,13 +84,16 @@ remqueue (SCM q, SCM c)
if (scm_is_eq (c, SCM_CAR (q)))
SCM_SETCAR (q, SCM_CDR (c));
SCM_SETCDR (prev, SCM_CDR (c));
- return;
+ return 1;
}
prev = p;
}
- abort ();
+ return 0;
}
+/* Remove the front-most element from the queue Q and return it.
+ Return SCM_BOOL_F when Q is empty.
+*/
static SCM
dequeue (SCM q)
{
@@ -95,76 +109,27 @@ dequeue (SCM q)
}
}
-/*** 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;
-}
+/*** Thread smob routines */
static SCM
thread_mark (SCM obj)
{
- scm_thread *t = SCM_THREAD_DATA (obj);
+ scm_i_thread *t = SCM_I_THREAD_DATA (obj);
scm_gc_mark (t->result);
- return t->root->handle; /* mark root-state of this thread */
+ scm_gc_mark (t->join_queue);
+ scm_gc_mark (t->dynwinds);
+ scm_gc_mark (t->active_asyncs);
+ scm_gc_mark (t->signal_asyncs);
+ scm_gc_mark (t->continuation_root);
+ return t->dynamic_state;
}
static int
thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_thread *t = SCM_THREAD_DATA (exp);
+ scm_i_thread *t = SCM_I_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);
@@ -174,29 +139,92 @@ thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
static size_t
thread_free (SCM obj)
{
- scm_thread *t = SCM_THREAD_DATA (obj);
- if (!t->exited)
- abort ();
+ scm_i_thread *t = SCM_I_THREAD_DATA (obj);
+ assert (t->exited);
scm_gc_free (t, sizeof (*t), "thread");
return 0;
}
-/*** Scheduling */
+/*** Blocking on queues. */
+
+/* See also scm_i_queue_async_cell for how such a block is
+ interrputed.
+*/
-#define cur_thread (SCM_CURRENT_THREAD->handle)
-scm_t_key scm_i_thread_key;
-scm_t_key scm_i_root_state_key;
+/* Put the current thread on QUEUE and go to sleep, waiting for it to
+ be woken up by a call to 'unblock_from_queue', or to be
+ interrupted. Upon return of this function, the current thread is
+ no longer on QUEUE, even when the sleep has been interrupted.
-void
-scm_i_set_thread_data (void *data)
+ The QUEUE data structure is assumed to be protected by MUTEX and
+ the caller of block_self must hold MUTEX. It will be atomically
+ unlocked while sleeping, just as with scm_i_pthread_cond_wait.
+
+ SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
+ as MUTEX is needed.
+
+ When WAITTIME is not NULL, the sleep will be aborted at that time.
+
+ The return value of block_self is an errno value. It will be zero
+ when the sleep has been successfully completed by a call to
+ unblock_from_queue, EINTR when it has been interrupted by the
+ delivery of a system async, and ETIMEDOUT when the timeout has
+ expired.
+
+ The system asyncs themselves are not executed by block_self.
+*/
+static int
+block_self (SCM queue, SCM sleep_object, scm_i_pthread_mutex_t *mutex,
+ const scm_t_timespec *waittime)
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ SCM q_handle;
+ int err;
+
+ if (scm_i_setup_sleep (t, sleep_object, mutex, -1))
+ err = EINTR;
+ else
+ {
+ t->block_asyncs++;
+ q_handle = enqueue (queue, t->handle);
+ if (waittime == NULL)
+ err = scm_i_scm_pthread_cond_wait (&t->sleep_cond, mutex);
+ else
+ err = scm_i_scm_pthread_cond_timedwait (&t->sleep_cond, mutex, waittime);
+
+ /* When we are still on QUEUE, we have been interrupted. We
+ report this only when no other error (such as a timeout) has
+ happened above.
+ */
+ if (remqueue (queue, q_handle) && err == 0)
+ err = EINTR;
+ t->block_asyncs--;
+ scm_i_reset_sleep (t);
+ }
+
+ return err;
+}
+
+/* Wake up the first thread on QUEUE, if any. The caller must hold
+ the mutex that protects QUEUE. The awoken thread is returned, or
+ #f when the queue was empty.
+ */
+static SCM
+unblock_from_queue (SCM queue)
{
- scm_thread *t = SCM_CURRENT_THREAD;
- scm_setspecific (scm_i_root_state_key, data);
- t->root = (scm_root_state *)data;
+ SCM thread = dequeue (queue);
+ if (scm_is_true (thread))
+ scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread)->sleep_cond);
+ return thread;
}
-
+
+/* Getting into and out of guile mode.
+ */
+
+scm_i_pthread_key_t scm_i_thread_key;
+
static void
-resume (scm_thread *t)
+resume (scm_i_thread *t)
{
t->top = NULL;
if (t->clear_freelists_p)
@@ -208,242 +236,476 @@ resume (scm_thread *t)
}
void
-scm_i_enter_guile (scm_thread *t)
+scm_enter_guile (scm_t_guile_ticket ticket)
{
- scm_i_plugin_mutex_lock (&t->heap_mutex);
- resume (t);
+ scm_i_thread *t = (scm_i_thread *)ticket;
+ if (t)
+ {
+ scm_i_pthread_mutex_lock (&t->heap_mutex);
+ resume (t);
+ }
}
-static scm_thread *
-suspend ()
+static scm_i_thread *
+suspend (void)
{
- scm_thread *c = SCM_CURRENT_THREAD;
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
/* record top of stack for the GC */
- c->top = SCM_STACK_PTR (&c);
+ t->top = SCM_STACK_PTR (&t);
/* save registers. */
SCM_FLUSH_REGISTER_WINDOWS;
- setjmp (c->regs);
-
- return c;
+ setjmp (t->regs);
+ return t;
}
-scm_thread *
-scm_i_leave_guile ()
+scm_t_guile_ticket
+scm_leave_guile ()
{
- scm_thread *t = suspend ();
- scm_i_plugin_mutex_unlock (&t->heap_mutex);
- return t;
+ scm_i_thread *t = suspend ();
+ scm_i_pthread_mutex_unlock (&t->heap_mutex);
+ return (scm_t_guile_ticket) t;
}
-/* Put the current thread to sleep until it is explicitely unblocked.
+static scm_i_pthread_mutex_t thread_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static scm_i_thread *all_threads = NULL;
+static int thread_count;
+
+static SCM scm_i_default_dynamic_state;
+
+/* Perform first stage of thread initialisation, in non-guile mode.
*/
-static int
-block ()
+static void
+guilify_self_1 (SCM_STACKITEM *base)
{
- int err;
- scm_thread *t = suspend ();
- err = scm_i_plugin_cond_wait (&t->sleep_cond, &t->heap_mutex);
- resume (t);
- return err;
+ scm_i_thread *t = malloc (sizeof (scm_i_thread));
+
+ t->pthread = scm_i_pthread_self ();
+ t->handle = SCM_BOOL_F;
+ t->result = SCM_BOOL_F;
+ t->join_queue = SCM_EOL;
+ t->dynamic_state = SCM_BOOL_F;
+ t->dynwinds = SCM_EOL;
+ t->active_asyncs = SCM_EOL;
+ t->signal_asyncs = SCM_EOL;
+ t->block_asyncs = 1;
+ t->pending_asyncs = 1;
+ t->last_debug_frame = NULL;
+ t->base = base;
+ t->continuation_base = base;
+ scm_i_pthread_cond_init (&t->sleep_cond, NULL);
+ t->sleep_mutex = NULL;
+ t->sleep_object = SCM_BOOL_F;
+ t->sleep_fd = -1;
+ pipe (t->sleep_pipe);
+ scm_i_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);
+
+ scm_i_pthread_setspecific (scm_i_thread_key, t);
+
+ scm_i_pthread_mutex_lock (&t->heap_mutex);
+
+ scm_i_pthread_mutex_lock (&thread_admin_mutex);
+ t->next_thread = all_threads;
+ all_threads = t;
+ thread_count++;
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
}
-/* Put the current thread to sleep until it is explicitely unblocked
- or until a signal arrives or until time AT (absolute time) is
- reached. Return 0 when it has been unblocked; errno otherwise.
+/* Perform second stage of thread initialisation, in guile mode.
*/
-static int
-timed_block (const scm_t_timespec *at)
+static void
+guilify_self_2 (SCM parent)
{
- int err;
- scm_thread *t = suspend ();
- err = scm_i_plugin_cond_timedwait (&t->sleep_cond, &t->heap_mutex, at);
- resume (t);
- return err;
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ SCM_NEWSMOB (t->handle, scm_tc16_thread, t);
+ scm_gc_register_collectable_memory (t, sizeof (scm_i_thread), "thread");
+ t->continuation_root = scm_cons (t->handle, SCM_EOL);
+ t->continuation_base = t->base;
+
+ if (scm_is_true (parent))
+ t->dynamic_state = scm_make_dynamic_state (parent);
+ else
+ t->dynamic_state = scm_i_make_initial_dynamic_state ();
+
+ t->join_queue = make_queue ();
+ t->block_asyncs = 0;
}
-/* Unblock a sleeping thread.
+/* Perform thread tear-down, in guile mode.
*/
+static void *
+do_thread_exit (void *v)
+{
+ scm_i_thread *t = (scm_i_thread *)v, **tp;
+
+ scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+
+ t->exited = 1;
+ while (scm_is_true (unblock_from_queue (t->join_queue)))
+ ;
+
+ for (tp = &all_threads; *tp; tp = &(*tp)->next_thread)
+ if (*tp == t)
+ {
+ *tp = t->next_thread;
+ break;
+ }
+ thread_count--;
+
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+ return NULL;
+}
+
static void
-unblock (scm_thread *t)
+on_thread_exit (void *v)
{
- scm_i_plugin_cond_signal (&t->sleep_cond);
+ scm_i_pthread_setspecific (scm_i_thread_key, v);
+ scm_with_guile (do_thread_exit, v);
+ scm_i_pthread_setspecific (scm_i_thread_key, NULL);
}
-/*** Thread creation */
+static scm_i_pthread_once_t init_thread_key_once = SCM_I_PTHREAD_ONCE_INIT;
-static scm_t_mutex thread_admin_mutex;
-static SCM all_threads;
-static int thread_count;
+static void
+init_thread_key (void)
+{
+ scm_i_pthread_key_create (&scm_i_thread_key, on_thread_exit);
+}
-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;
+/* Perform any initializations necessary to bring the current thread
+ into guile mode, initializing Guile itself, if necessary.
-static SCM
-body_bootstrip (launch_data* data)
+ BASE is the stack base to use with GC.
+
+ PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
+ which case the default dynamic state is used.
+
+ Return zero when the thread was in guile mode already; otherwise
+ return 1.
+*/
+
+static int
+scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
{
- /* First save the new root continuation */
- data->rootcont = scm_root->rootcont;
- return (data->body) (data->body_data);
+ scm_i_thread *t;
+
+ scm_i_pthread_once (&init_thread_key_once, init_thread_key);
+
+ if ((t = SCM_I_CURRENT_THREAD) == NULL)
+ {
+ /* This thread has not been guilified yet.
+ */
+
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
+ }
+ else
+ {
+ /* Guile is already initialized, but this thread enters it for
+ the first time. Only initialize this thread.
+ */
+ scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
+ guilify_self_1 (base);
+ guilify_self_2 (parent);
+ }
+ return 1;
+ }
+ else if (t->top)
+ {
+ /* This thread is already guilified but not in guile mode, just
+ resume it.
+
+ XXX - base might be lower than when this thread was first
+ guilified.
+ */
+ scm_enter_guile ((scm_t_guile_ticket) t);
+ return 1;
+ }
+ else
+ {
+ /* Thread is already in guile mode. Nothing to do.
+ */
+ return 0;
+ }
}
-static SCM
-handler_bootstrip (launch_data* data, SCM tag, SCM throw_args)
+#ifdef HAVE_LIBC_STACK_END
+
+extern void *__libc_stack_end;
+
+#if SCM_USE_PTHREAD_THREADS
+#ifdef HAVE_PTHREAD_ATTR_GETSTACK
+
+#define HAVE_GET_THREAD_STACK_BASE
+
+static SCM_STACKITEM *
+get_thread_stack_base ()
{
- scm_root->rootcont = data->rootcont;
- return (data->handler) (data->handler_data, tag, throw_args);
+ pthread_attr_t attr;
+ void *start, *end;
+ size_t size;
+
+ /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
+ for the main thread, but we can use __libc_stack_end in that
+ case.
+ */
+
+ 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
+ {
+#if SCM_STACK_GROWS_UP
+ return start;
+#else
+ return end;
+#endif
+ }
}
-static void
-really_launch (SCM_STACKITEM *base, launch_data *data)
+#endif /* HAVE_PTHREAD_ATTR_GETSTACK */
+
+#else /* !SCM_USE_PTHREAD_THREADS */
+
+#define HAVE_GET_THREAD_STACK_BASE
+
+static SCM_STACKITEM *
+get_thread_stack_base ()
{
- 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);
- t->exited = 1;
- 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);
+ return __libc_stack_end;
}
-static void *
-launch_thread (void *p)
+#endif /* !SCM_USE_PTHREAD_THREADS */
+#endif /* HAVE_LIBC_STACK_END */
+
+#ifdef HAVE_GET_THREAD_STACK_BASE
+
+void
+scm_init_guile ()
{
- really_launch (SCM_STACK_PTR (&p), (launch_data *) p);
- return 0;
+ scm_i_init_thread_for_guile (get_thread_stack_base (),
+ scm_i_default_dynamic_state);
}
-static SCM
-create_thread (scm_t_catch_body body, void *body_data,
- scm_t_catch_handler handler, void *handler_data,
- SCM protects)
+#endif
+
+void *
+scm_with_guile (void *(*func)(void *), void *data)
+{
+ return scm_i_with_guile_and_parent (func, data,
+ scm_i_default_dynamic_state);
+}
+
+void *
+scm_i_with_guile_and_parent (void *(*func)(void *), void *data,
+ SCM parent)
+{
+ void *res;
+ int really_entered;
+ SCM_STACKITEM base_item;
+ really_entered = scm_i_init_thread_for_guile (&base_item, parent);
+ res = scm_c_with_continuation_barrier (func, data);
+ if (really_entered)
+ scm_leave_guile ();
+ return res;
+}
+
+void *
+scm_without_guile (void *(*func)(void *), void *data)
{
+ void *res;
+ scm_t_guile_ticket t;
+ t = scm_leave_guile ();
+ res = func (data);
+ scm_enter_guile (t);
+ return res;
+}
+
+/*** Thread creation */
+
+typedef struct {
+ SCM parent;
+ SCM thunk;
+ SCM handler;
SCM thread;
+ scm_i_pthread_mutex_t mutex;
+ scm_i_pthread_cond_t cond;
+} launch_data;
- /* 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.
- */
-
- {
- 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. */
- {
- 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);
- }
-
- 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);
- }
+static void *
+really_launch (void *d)
+{
+ launch_data *data = (launch_data *)d;
+ SCM thunk = data->thunk, handler = data->handler;
+ scm_i_thread *t;
- if (err)
- {
- errno = err;
- scm_syserror ("create-thread");
- }
- }
+ t = SCM_I_CURRENT_THREAD;
- return thread;
+ scm_i_scm_pthread_mutex_lock (&data->mutex);
+ data->thread = scm_current_thread ();
+ scm_i_pthread_cond_signal (&data->cond);
+ scm_i_pthread_mutex_unlock (&data->mutex);
+
+ if (SCM_UNBNDP (handler))
+ t->result = scm_call_0 (thunk);
+ else
+ t->result = scm_catch (SCM_BOOL_T, thunk, handler);
+
+ return 0;
}
-SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 2, 0, 0,
+static void *
+launch_thread (void *d)
+{
+ launch_data *data = (launch_data *)d;
+ scm_i_pthread_detach (scm_i_pthread_self ());
+ scm_i_with_guile_and_parent (really_launch, d, data->parent);
+ return NULL;
+}
+
+SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 1, 1, 0,
(SCM thunk, SCM handler),
-"Evaluate @code{(@var{thunk})} in a new thread, and new dynamic context, "
-"returning a new thread object representing the thread. "
-"If an error occurs during evaluation, call error-thunk, passing it an "
-"error code describing the condition. "
-"If this happens, the error-thunk is called outside the scope of the new "
-"root -- it is called in the same dynamic context in which "
-"with-new-thread was evaluated, but not in the callers thread. "
-"All the evaluation rules for dynamic roots apply to threads.")
+ "Call @code{thunk} in a new thread and with a new dynamic state,\n"
+ "returning a new thread object representing the thread. The procedure\n"
+ "@var{thunk} is called via @code{with-continuation-barrier}.\n"
+ "\n"
+ "When @var{handler} is specified, then @var{thunk} is called from\n"
+ "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
+ "handler. This catch is established inside the continuation barrier.\n"
+ "\n"
+ "Once @var{thunk} or @var{handler} returns, the return value is made\n"
+ "the @emph{exit value} of the thread and the thread is terminated.")
#define FUNC_NAME s_scm_call_with_new_thread
{
- 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);
+ launch_data data;
+ scm_i_pthread_t id;
+ int err;
- return create_thread ((scm_t_catch_body) scm_call_0, thunk,
- (scm_t_catch_handler) scm_apply_1, handler,
- scm_cons (thunk, handler));
+ SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), thunk, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_UNBNDP (handler) || scm_is_true (scm_procedure_p (handler)),
+ handler, SCM_ARG2, FUNC_NAME);
+
+ data.parent = scm_current_dynamic_state ();
+ data.thunk = thunk;
+ data.handler = handler;
+ data.thread = SCM_BOOL_F;
+ scm_i_pthread_mutex_init (&data.mutex, NULL);
+ scm_i_pthread_cond_init (&data.cond, NULL);
+
+ scm_i_scm_pthread_mutex_lock (&data.mutex);
+ err = scm_i_pthread_create (&id, NULL, launch_thread, &data);
+ if (err)
+ {
+ scm_i_pthread_mutex_unlock (&data.mutex);
+ errno = err;
+ scm_syserror (NULL);
+ }
+ scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
+ scm_i_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;
+ scm_i_pthread_mutex_t mutex;
+ scm_i_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_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ scm_i_scm_pthread_mutex_lock (&data->mutex);
+ data->thread = scm_current_thread ();
+ scm_i_pthread_cond_signal (&data->cond);
+ scm_i_pthread_mutex_unlock (&data->mutex);
+
+ if (handler == NULL)
+ t->result = body (body_data);
+ else
+ t->result = scm_internal_catch (SCM_BOOL_T,
+ body, body_data,
+ handler, handler_data);
+
+ return 0;
+}
+
+static void *
+spawn_thread (void *d)
+{
+ spawn_data *data = (spawn_data *)d;
+ scm_i_pthread_detach (scm_i_pthread_self ());
+ scm_i_with_guile_and_parent (really_spawn, d, data->parent);
+ return NULL;
+}
+
+SCM
+scm_spawn_thread (scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data)
+{
+ spawn_data data;
+ scm_i_pthread_t id;
+ int err;
+
+ data.parent = scm_current_dynamic_state ();
+ data.body = body;
+ data.body_data = body_data;
+ data.handler = handler;
+ data.handler_data = handler_data;
+ data.thread = SCM_BOOL_F;
+ scm_i_pthread_mutex_init (&data.mutex, NULL);
+ scm_i_pthread_cond_init (&data.cond, NULL);
+
+ scm_i_scm_pthread_mutex_lock (&data.mutex);
+ err = scm_i_pthread_create (&id, NULL, spawn_thread, &data);
+ if (err)
+ {
+ scm_i_pthread_mutex_unlock (&data.mutex);
+ errno = err;
+ scm_syserror (NULL);
+ }
+ scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
+ scm_i_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 (scm_i_sched_yield ());
}
#undef FUNC_NAME
@@ -453,251 +715,148 @@ SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
"terminates, unless the target @var{thread} has already terminated. ")
#define FUNC_NAME s_scm_join_thread
{
- scm_thread *t;
+ scm_i_thread *t;
SCM res;
SCM_VALIDATE_THREAD (1, thread);
- if (scm_is_eq (cur_thread, thread))
+ if (scm_is_eq (scm_current_thread (), thread))
SCM_MISC_ERROR ("can not join the current thread", SCM_EOL);
- t = SCM_THREAD_DATA (thread);
+ scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+
+ t = SCM_I_THREAD_DATA (thread);
if (!t->exited)
{
- scm_thread *c;
- c = scm_i_leave_guile ();
- while (!THREAD_INITIALIZED_P (t))
- scm_i_plugin_thread_yield ();
- scm_thread_join (t->thread, 0);
- scm_i_enter_guile (c);
+ while (1)
+ {
+ block_self (t->join_queue, thread, &thread_admin_mutex, NULL);
+ if (t->exited)
+ break;
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+ SCM_TICK;
+ scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+ }
}
res = t->result;
- t->result = SCM_BOOL_F;
+
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
return res;
}
#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
- asyncs) and we want to support waiting on many things at once.
- Also, we might add things that are nice for debugging.
+ asyncs) and we might want to 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 {
+ scm_i_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;
+
+#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
+#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
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)
+static size_t
+fat_mutex_free (SCM mx)
{
- 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);
+ fat_mutex *m = SCM_MUTEX_DATA (mx);
+ scm_i_pthread_mutex_destroy (&m->lock);
+ scm_gc_free (m, sizeof (fat_mutex), "mutex");
return 0;
}
static int
-fair_mutex_trylock (fair_mutex *m)
+fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- 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;
+ 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 int
-fair_mutex_unlock (fair_mutex *m)
+static SCM
+make_fat_mutex (int recursive)
{
- 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;
-}
+ fat_mutex *m;
+ SCM mx;
-/*** 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;
+ m = scm_gc_malloc (sizeof (fat_mutex), "mutex");
+ scm_i_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;
+}
-static SCM
-fair_cond_mark (SCM cv)
+SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0,
+ (void),
+ "Create a new mutex. ")
+#define FUNC_NAME s_scm_make_mutex
{
- fair_cond *c = SCM_CONDVAR_DATA (cv);
- return c->waiting;
+ return make_fat_mutex (0);
}
+#undef FUNC_NAME
-SCM_DEFINE (scm_make_fair_condition_variable, "make-fair-condition-variable", 0, 0, 0,
+SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0,
(void),
- "Make a new fair condition variable.")
-#define FUNC_NAME s_scm_make_fair_condition_variable
+ "Create a new recursive mutex. ")
+#define FUNC_NAME s_scm_make_recursive_mutex
{
- 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;
+ return make_fat_mutex (1);
}
#undef FUNC_NAME
-static int
-fair_cond_timedwait (fair_cond *c,
- fair_mutex *m,
- const scm_t_timespec *waittime)
+static char *
+fat_mutex_lock (SCM mutex)
{
- int err;
- scm_i_plugin_mutex_lock (&c->lock);
+ fat_mutex *m = SCM_MUTEX_DATA (mutex);
+ SCM thread = scm_current_thread ();
+ char *msg = NULL;
- while (1)
+ scm_i_scm_pthread_mutex_lock (&m->lock);
+ if (scm_is_false (m->owner))
+ m->owner = thread;
+ else if (scm_is_eq (m->owner, thread))
{
- 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 ();
+ if (m->level >= 0)
+ m->level++;
else
- err = timed_block (waittime);
- fair_mutex_lock (m);
- if (err)
- return err;
- /* XXX - check whether we have been signalled. */
- break;
+ msg = "mutex already locked by current thread";
}
- return err;
-}
-
-static int
-fair_cond_signal (fair_cond *c)
-{
- 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);
- return 0;
-}
-
-static int
-fair_cond_broadcast (fair_cond *c)
-{
- 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;
-}
-
-/*** Mutexes */
-
-SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0,
- (void),
- "Create a new mutex object. ")
-#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;
+ else
+ {
+ while (1)
+ {
+ block_self (m->waiting, mutex, &m->lock, NULL);
+ if (scm_is_eq (m->owner, thread))
+ break;
+ scm_i_pthread_mutex_unlock (&m->lock);
+ SCM_TICK;
+ scm_i_scm_pthread_mutex_lock (&m->lock);
+ }
+ }
+ scm_i_pthread_mutex_unlock (&m->lock);
+ return msg;
}
-#undef FUNC_NAME
-/*fixme* change documentation */
SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
(SCM mx),
"Lock @var{mutex}. If the mutex is already locked, the calling thread "
@@ -707,55 +866,78 @@ SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
"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
- {
- scm_t_mutex *m = SCM_MUTEX_DATA (mx);
- err = scm_mutex_lock (m);
- }
+ char *msg;
- if (err)
- {
- errno = err;
- SCM_SYSERROR;
- }
+ msg = fat_mutex_lock (mx);
+ if (msg)
+ scm_misc_error (NULL, msg, SCM_EOL);
return SCM_BOOL_T;
}
#undef FUNC_NAME
+static char *
+fat_mutex_trylock (fat_mutex *m, int *resp)
+{
+ char *msg = NULL;
+ SCM thread = scm_current_thread ();
+
+ *resp = 1;
+ scm_i_pthread_mutex_lock (&m->lock);
+ if (scm_is_false (m->owner))
+ m->owner = thread;
+ else if (scm_is_eq (m->owner, thread))
+ {
+ if (m->level >= 0)
+ m->level++;
+ else
+ msg = "mutex already locked by current thread";
+ }
+ else
+ *resp = 0;
+ scm_i_pthread_mutex_unlock (&m->lock);
+ return msg;
+}
+
SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0,
(SCM mx),
"Try to lock @var{mutex}. If the mutex is already locked by someone "
"else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
#define FUNC_NAME s_scm_try_mutex
{
- int err;
+ char *msg;
+ int res;
+
SCM_VALIDATE_MUTEX (1, mx);
- if (SCM_TYP16 (mx) == scm_tc16_fair_mutex)
- err = fair_mutex_trylock (SCM_MUTEX_DATA (mx));
- else
- {
- scm_t_mutex *m = SCM_MUTEX_DATA (mx);
- err = scm_mutex_trylock (m);
- }
+ msg = fat_mutex_trylock (SCM_MUTEX_DATA (mx), &res);
+ if (msg)
+ scm_misc_error (NULL, msg, SCM_EOL);
+ return scm_from_bool (res);
+}
+#undef FUNC_NAME
- if (err == EBUSY)
- return SCM_BOOL_F;
-
- if (err)
+static char *
+fat_mutex_unlock (fat_mutex *m)
+{
+ char *msg = NULL;
+
+ scm_i_scm_pthread_mutex_lock (&m->lock);
+ if (!scm_is_eq (m->owner, scm_current_thread ()))
{
- errno = err;
- SCM_SYSERROR;
+ if (scm_is_false (m->owner))
+ msg = "mutex not locked";
+ else
+ msg = "mutex not locked by current thread";
}
-
- return SCM_BOOL_T;
+ else if (m->level > 0)
+ m->level--;
+ else
+ m->owner = unblock_from_queue (m->waiting);
+ scm_i_pthread_mutex_unlock (&m->lock);
+
+ return msg;
}
-#undef FUNC_NAME
SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0,
(SCM mx),
@@ -768,52 +950,142 @@ SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0,
"@code{unlock-mutex} will actually unlock the mutex. ")
#define FUNC_NAME s_scm_unlock_mutex
{
- int err;
+ char *msg;
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;
- }
+ msg = fat_mutex_unlock (SCM_MUTEX_DATA (mx));
+ if (msg)
+ scm_misc_error (NULL, msg, SCM_EOL);
return SCM_BOOL_T;
}
#undef FUNC_NAME
-/*** Condition variables */
+#if 0
+
+SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0,
+ (SCM mx),
+ "Return the thread owning @var{mx}, or @code{#f}.")
+#define FUNC_NAME s_scm_mutex_owner
+{
+ SCM_VALIDATE_MUTEX (1, mx);
+ return (SCM_MUTEX_DATA(mx))->owner;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0,
+ (SCM mx),
+ "Return the lock level of a recursive mutex, or -1\n"
+ "for a standard mutex.")
+#define FUNC_NAME s_scm_mutex_level
+{
+ SCM_VALIDATE_MUTEX (1, mx);
+ return scm_from_int (SCM_MUTEX_DATA(mx)->level);
+}
+#undef FUNC_NAME
+
+#endif
+
+/*** Fat condition variables */
+
+typedef struct {
+ scm_i_pthread_mutex_t lock;
+ SCM waiting; /* the threads waiting for this condition. */
+} fat_cond;
+
+#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
+#define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
+
+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);
+ scm_i_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");
+ scm_i_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 int
+fat_cond_timedwait (SCM cond, SCM mutex,
+ const scm_t_timespec *waittime)
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ fat_cond *c = SCM_CONDVAR_DATA (cond);
+ fat_mutex *m = SCM_MUTEX_DATA (mutex);
+ const char *msg;
+ int err = 0;
+
+ while (1)
+ {
+ fprintf (stderr, "cond wait on %p\n", &c->lock);
+
+ scm_i_scm_pthread_mutex_lock (&c->lock);
+ msg = fat_mutex_unlock (m);
+ t->block_asyncs++;
+ if (msg == NULL)
+ {
+ err = block_self (c->waiting, cond, &c->lock, waittime);
+ scm_i_pthread_mutex_unlock (&c->lock);
+ fprintf (stderr, "locking mutex\n");
+ fat_mutex_lock (mutex);
+ }
+ else
+ scm_i_pthread_mutex_unlock (&c->lock);
+ t->block_asyncs--;
+ scm_async_click ();
+
+ fprintf (stderr, "back: %s, %d\n", msg, err);
+
+ if (msg)
+ scm_misc_error (NULL, msg, SCM_EOL);
+
+ scm_remember_upto_here_2 (cond, mutex);
+
+ if (err == 0)
+ return 1;
+ if (err == ETIMEDOUT)
+ return 0;
+ if (err != EINTR)
+ {
+ errno = err;
+ scm_syserror (NULL);
+ }
+ }
+}
+
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, "
@@ -827,88 +1099,67 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1,
"is returned. ")
#define FUNC_NAME s_scm_timed_wait_condition_variable
{
- scm_t_timespec waittime;
- int err;
+ scm_t_timespec waittime, *waitptr = NULL;
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;
}
+ waitptr = &waittime;
}
- 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;
- }
- return SCM_BOOL_T;
+ return scm_from_bool (fat_cond_timedwait (cv, mx, waitptr));
}
#undef FUNC_NAME
+static void
+fat_cond_signal (fat_cond *c)
+{
+ fprintf (stderr, "cond signal on %p\n", &c->lock);
+
+ scm_i_scm_pthread_mutex_lock (&c->lock);
+ unblock_from_queue (c->waiting);
+ scm_i_pthread_mutex_unlock (&c->lock);
+}
+
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 void
+fat_cond_broadcast (fat_cond *c)
+{
+ scm_i_scm_pthread_mutex_lock (&c->lock);
+ while (scm_is_true (unblock_from_queue (c->waiting)))
+ ;
+ scm_i_pthread_mutex_unlock (&c->lock);
+}
+
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
@@ -936,31 +1187,20 @@ SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1,
void
scm_threads_mark_stacks (void)
{
- volatile SCM c;
-
- for (c = all_threads; !scm_is_null (c); c = SCM_CDR (c))
+ scm_i_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)));
@@ -972,129 +1212,119 @@ scm_threads_mark_stacks (void)
/*** Select */
int
-scm_internal_select (int nfds,
- SELECT_TYPE *readfds,
- SELECT_TYPE *writefds,
- SELECT_TYPE *exceptfds,
- struct timeval *timeout)
-{
- int res, eno;
- scm_thread *c = scm_i_leave_guile ();
- res = scm_i_plugin_select (nfds, readfds, writefds, exceptfds, timeout);
+scm_std_select (int nfds,
+ SELECT_TYPE *readfds,
+ SELECT_TYPE *writefds,
+ SELECT_TYPE *exceptfds,
+ struct timeval *timeout)
+{
+ fd_set my_readfds;
+ int res, eno, wakeup_fd;
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ scm_t_guile_ticket ticket;
+
+ if (readfds == NULL)
+ {
+ FD_ZERO (&my_readfds);
+ readfds = &my_readfds;
+ }
+
+ while (scm_i_setup_sleep (t, SCM_BOOL_F, NULL, t->sleep_pipe[1]))
+ SCM_TICK;
+
+ wakeup_fd = t->sleep_pipe[0];
+ ticket = scm_leave_guile ();
+ FD_SET (wakeup_fd, readfds);
+ if (wakeup_fd >= nfds)
+ nfds = wakeup_fd+1;
+ res = select (nfds, readfds, writefds, exceptfds, timeout);
+ t->sleep_fd = -1;
eno = errno;
- scm_i_enter_guile (c);
- SCM_ASYNC_TICK;
+ scm_enter_guile (ticket);
+
+ scm_i_reset_sleep (t);
+
+ if (res > 0 && FD_ISSET (wakeup_fd, readfds))
+ {
+ char dummy;
+ read (wakeup_fd, &dummy, 1);
+ FD_CLR (wakeup_fd, readfds);
+ res -= 1;
+ if (res == 0)
+ {
+ eno = EINTR;
+ res = -1;
+ }
+ }
errno = eno;
return res;
}
-/* Low-level C API */
+/* Convenience API for blocking while in guile mode. */
-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;
-}
+#if SCM_USE_PTHREAD_THREADS
int
-scm_mutex_lock (scm_t_mutex *m)
+scm_pthread_mutex_lock (scm_i_pthread_mutex_t *mutex)
{
- scm_thread *t = scm_i_leave_guile ();
- int res = scm_i_plugin_mutex_lock (m);
- scm_i_enter_guile (t);
+ scm_t_guile_ticket t = scm_leave_guile ();
+ int res = scm_i_pthread_mutex_lock (mutex);
+ scm_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;
+ scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t *)data);
}
void
-scm_rec_mutex_free (scm_t_rec_mutex *m)
+scm_frame_pthread_mutex_lock (scm_i_pthread_mutex_t *mutex)
{
- scm_i_plugin_rec_mutex_destroy (m);
- free (m);
-}
-
-int
-scm_rec_mutex_lock (scm_t_rec_mutex *m)
-{
- scm_thread *t = scm_i_leave_guile ();
- int res = scm_i_plugin_rec_mutex_lock (m);
- scm_i_enter_guile (t);
- return res;
-}
-
-int
-scm_cond_wait (scm_t_cond *c, scm_t_mutex *m)
-{
- scm_thread *t = scm_i_leave_guile ();
- scm_i_plugin_cond_wait (c, m);
- scm_i_enter_guile (t);
- return 0;
+ scm_i_scm_pthread_mutex_lock (mutex);
+ scm_frame_unwind_handler (unlock, mutex, SCM_F_WIND_EXPLICITLY);
}
int
-scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m, const scm_t_timespec *wt)
+scm_pthread_cond_wait (scm_i_pthread_cond_t *cond, scm_i_pthread_mutex_t *mutex)
{
- scm_thread *t = scm_i_leave_guile ();
- int res = scm_i_plugin_cond_timedwait (c, m, wt);
- scm_i_enter_guile (t);
+ scm_t_guile_ticket t = scm_leave_guile ();
+ int res = scm_i_pthread_cond_wait (cond, mutex);
+ scm_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)
+scm_pthread_cond_timedwait (scm_i_pthread_cond_t *cond,
+ scm_i_pthread_mutex_t *mutex,
+ const scm_t_timespec *wt)
{
- return scm_i_plugin_setspecific (k, s);
-}
-
-void
-scm_enter_guile ()
-{
- scm_i_enter_guile (SCM_CURRENT_THREAD);
+ scm_t_guile_ticket t = scm_leave_guile ();
+ int res = scm_i_pthread_cond_timedwait (cond, mutex, wt);
+ scm_enter_guile (t);
+ return res;
}
-void
-scm_leave_guile ()
-{
- scm_i_leave_guile ();
-}
+#endif
unsigned long
-scm_thread_usleep (unsigned long usecs)
+scm_std_usleep (unsigned long usecs)
{
struct timeval tv;
tv.tv_usec = usecs % 1000000;
tv.tv_sec = usecs / 1000000;
- scm_internal_select (0, NULL, NULL, NULL, &tv);
- return tv.tv_usec + tv.tv_sec*1000000;
+ scm_std_select (0, NULL, NULL, NULL, &tv);
+ return tv.tv_sec * 1000000 + tv.tv_usec;
}
-unsigned long
-scm_thread_sleep (unsigned long secs)
+unsigned int
+scm_std_sleep (unsigned int secs)
{
struct timeval tv;
tv.tv_usec = 0;
tv.tv_sec = secs;
- scm_internal_select (0, NULL, NULL, NULL, &tv);
+ scm_std_select (0, NULL, NULL, NULL, &tv);
return tv.tv_sec;
}
@@ -1105,24 +1335,44 @@ SCM_DEFINE (scm_current_thread, "current-thread", 0, 0, 0,
"Return the thread that called this function.")
#define FUNC_NAME s_scm_current_thread
{
- return cur_thread;
+ return SCM_I_CURRENT_THREAD->handle;
}
#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);
-}
-#undef FUNC_NAME
+ /* We can not allocate while holding the thread_admin_mutex because
+ of the way GC is done.
+ */
+ int n = thread_count;
+ scm_i_thread *t;
+ SCM list = scm_c_make_list (n, SCM_UNSPECIFIED), *l;
-scm_root_state *
-scm_i_thread_root (SCM thread)
-{
- return ((scm_thread *) SCM_THREAD_DATA (thread))->root;
+ scm_i_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;
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+ return list;
}
+#undef FUNC_NAME
SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0,
(SCM thread),
@@ -1137,53 +1387,59 @@ int
scm_c_thread_exited_p (SCM thread)
#define FUNC_NAME s_scm_thread_exited_p
{
- scm_thread *t;
+ scm_i_thread *t;
SCM_VALIDATE_THREAD (1, thread);
- t = SCM_THREAD_DATA (thread);
+ t = SCM_I_THREAD_DATA (thread);
return t->exited;
}
#undef FUNC_NAME
-static scm_t_cond wake_up_cond;
+static scm_i_pthread_cond_t wake_up_cond;
int scm_i_thread_go_to_sleep;
static int threads_initialized_p = 0;
+static int sleep_level = 0;
void
scm_i_thread_put_to_sleep ()
{
if (threads_initialized_p)
{
- SCM threads;
+ scm_i_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;
- /* Signal all threads to go to sleep */
- scm_i_thread_go_to_sleep = 1;
- for (; !scm_is_null (threads); threads = SCM_CDR (threads))
+ scm_leave_guile ();
+ scm_i_pthread_mutex_lock (&thread_admin_mutex);
+
+ if (sleep_level == 0)
{
- scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
- scm_i_plugin_mutex_lock (&t->heap_mutex);
+ /* Signal all threads to go to sleep
+ */
+ scm_i_thread_go_to_sleep = 1;
+ for (t = all_threads; t; t = t->next_thread)
+ scm_i_pthread_mutex_lock (&t->heap_mutex);
+ scm_i_thread_go_to_sleep = 0;
}
- scm_i_thread_go_to_sleep = 0;
+ else
+ {
+ /* We are already single threaded. Suspend again to update
+ the recorded stack information.
+ */
+ suspend ();
+ }
+ sleep_level += 1;
+
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
}
}
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_i_thread *t;
+ for (t = all_threads; t; t = t->next_thread)
+ if (t != SCM_I_CURRENT_THREAD)
+ t->clear_freelists_p = 1;
}
void
@@ -1191,122 +1447,116 @@ scm_i_thread_wake_up ()
{
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_i_thread *t;
+ scm_i_pthread_mutex_lock (&thread_admin_mutex);
+
+ sleep_level -= 1;
+ if (sleep_level == 0)
{
- scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
- scm_i_plugin_mutex_unlock (&t->heap_mutex);
+ scm_i_pthread_cond_broadcast (&wake_up_cond);
+ for (t = all_threads; t; t = t->next_thread)
+ scm_i_pthread_mutex_unlock (&t->heap_mutex);
}
- scm_i_plugin_mutex_unlock (&thread_admin_mutex);
- scm_i_enter_guile (SCM_CURRENT_THREAD);
+
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+ scm_enter_guile ((scm_t_guile_ticket) SCM_I_CURRENT_THREAD);
}
}
void
scm_i_thread_sleep_for_gc ()
{
- scm_thread *t;
- t = suspend ();
- scm_i_plugin_cond_wait (&wake_up_cond, &t->heap_mutex);
+ scm_i_thread *t = suspend ();
+ scm_i_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;
+static void
+put_to_sleep (void *unused)
+{
+ scm_i_thread_put_to_sleep ();
+}
-#if SCM_USE_PTHREAD_THREADS
-# include "libguile/pthread-threads.c"
-#endif
-#include "libguile/threads-plugin.c"
+static void
+wake_up (void *unused)
+{
+ scm_i_thread_wake_up ();
+}
-/*** Initialization */
+void
+scm_i_frame_single_threaded ()
+{
+ scm_frame_rewind_handler (put_to_sleep, NULL, SCM_F_WIND_EXPLICITLY);
+ scm_frame_unwind_handler (wake_up, NULL, SCM_F_WIND_EXPLICITLY);
+}
+
+scm_i_pthread_mutex_t scm_i_critical_section_mutex =
+ SCM_I_PTHREAD_MUTEX_INITIALIZER;
void
-scm_threads_prehistory ()
+scm_frame_critical_section ()
{
- 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_i_frame_pthread_mutex_lock (&scm_i_critical_section_mutex);
+ scm_frame_block_asyncs ();
+}
+
+/*** Initialization */
+
+scm_i_pthread_key_t scm_i_freelist, scm_i_freelist2;
+scm_i_pthread_mutex_t scm_i_misc_mutex;
+
+void
+scm_threads_prehistory (SCM_STACKITEM *base)
+{
+ scm_i_pthread_mutex_init (&thread_admin_mutex, NULL);
+ scm_i_pthread_mutex_init (&scm_i_misc_mutex, NULL);
+ scm_i_pthread_cond_init (&wake_up_cond, NULL);
+ scm_i_pthread_mutex_init (&scm_i_critical_section_mutex, NULL);
+ scm_i_pthread_key_create (&scm_i_freelist, NULL);
+ scm_i_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_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_i_thread));
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_default_dynamic_state = 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_thread_procs ()
+scm_init_threads_default_dynamic_state ()
{
-#include "libguile/threads.x"
+ SCM state = scm_make_dynamic_state (scm_current_dynamic_state ());
+ scm_i_default_dynamic_state = scm_permanent_object (state);
}
-/* XXX */
-
void
-scm_init_iselect ()
+scm_init_thread_procs ()
{
+#include "libguile/threads.x"
}
/*
diff --git a/libguile/threads.h b/libguile/threads.h
index 4faf54c3b..ad38653ed 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -27,165 +27,123 @@
#include "libguile/throw.h"
#include "libguile/root.h"
#include "libguile/iselect.h"
-#include "libguile/threads-plugin.h"
+#include "libguile/dynwind.h"
+
+#if SCM_USE_PTHREAD_THREADS
+#include "libguile/pthread-threads.h"
+#endif
+
+#if SCM_USE_NULL_THREADS
+#include "libguile/null-threads.h"
+#endif
+
/* 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;
-
-#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))
+typedef struct scm_i_thread {
+ struct scm_i_thread *next_thread;
+
+ SCM handle;
+ scm_i_pthread_t pthread;
+
+ SCM join_queue;
+ SCM result;
+ int exited;
+
+ SCM sleep_object;
+ scm_i_pthread_mutex_t *sleep_mutex;
+ scm_i_pthread_cond_t sleep_cond;
+ int sleep_fd, sleep_pipe[2];
+
+ /* This mutex represents this threads right to access the heap.
+ That right can temporarily be taken away by the GC.
+ */
+ scm_i_pthread_mutex_t heap_mutex;
+
+ /* The freelists of this thread. Each thread has its own lists so
+ that they can all allocate concurrently.
+ */
+ SCM freelist, freelist2;
+ int clear_freelists_p; /* set if GC was done while thread was asleep */
+
+ /* Other thread local things.
+ */
+ SCM dynamic_state;
+ scm_t_debug_frame *last_debug_frame;
+ SCM dynwinds;
+
+ /* For system asyncs.
+ */
+ SCM active_asyncs; /* The thunks to be run at the next
+ safe point */
+ SCM signal_asyncs; /* The pre-queued cells for signal handlers.
+ */
+ unsigned int block_asyncs; /* Non-zero means that asyncs should
+ not be run. */
+ unsigned int pending_asyncs; /* Non-zero means that asyncs might be pending.
+ */
+
+ /* The current continuation root and the stack base for it.
+
+ The continuation root is an arbitrary but unique object that
+ identifies a dynamic extent. Continuations created during that
+ extent can also only be invoked during it.
+
+ We use pairs where the car is the thread handle and the cdr links
+ to the previous pair. This might be used for better error
+ messages but is not essential for identifying continuation roots.
+
+ The continuation base is the far end of the stack upto which it
+ needs to be copied.
+ */
+ SCM continuation_root;
+ SCM_STACKITEM *continuation_base;
+
+ /* For keeping track of the stack and registers. */
+ SCM_STACKITEM *base;
+ SCM_STACKITEM *top;
+ jmp_buf regs;
+
+} scm_i_thread;
+
+#define SCM_I_IS_THREAD(x) SCM_SMOB_PREDICATE (scm_tc16_thread, x)
+#define SCM_I_THREAD_DATA(x) ((scm_i_thread *) SCM_SMOB_DATA (x))
#define SCM_VALIDATE_THREAD(pos, a) \
- SCM_MAKE_VALIDATE_MSG (pos, a, THREADP, "thread")
-
+ scm_assert_smob_type (scm_tc16_thread, (a))
#define SCM_VALIDATE_MUTEX(pos, a) \
- SCM_ASSERT_TYPE (SCM_MUTEXP (a) || SCM_FAIR_MUTEX_P (a), \
- a, pos, FUNC_NAME, "mutex");
-
+ scm_assert_smob_type (scm_tc16_mutex, (a))
#define SCM_VALIDATE_CONDVAR(pos, a) \
- SCM_ASSERT_TYPE (SCM_CONDVARP (a) || SCM_FAIR_CONDVAR_P (a), \
- a, pos, FUNC_NAME, "condition variable");
+ scm_assert_smob_type (scm_tc16_condvar, (a))
-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
+typedef void *scm_t_guile_ticket;
+SCM_API void scm_enter_guile (scm_t_guile_ticket ticket);
+SCM_API scm_t_guile_ticket scm_leave_guile (void);
+SCM_API void *scm_without_guile (void *(*func)(void *), void *data);
-/* 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.
- */
-
-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_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;
+/* XXX - every critical section needs to be examined and protected
+ with scm_frame_critical_section, say.
+*/
+
+extern scm_i_pthread_mutex_t scm_i_critical_section_mutex;
#define SCM_CRITICAL_SECTION_START \
- scm_mutex_lock (&scm_i_critical_section_mutex)
+ scm_i_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;
+ scm_i_pthread_mutex_unlock (&scm_i_critical_section_mutex)
extern int scm_i_thread_go_to_sleep;
@@ -193,8 +151,15 @@ void scm_i_thread_put_to_sleep (void);
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);
+SCM_API void scm_i_frame_single_threaded (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_default_dynamic_state (void);
+
#define SCM_THREAD_SWITCHING_CODE \
do { \
@@ -202,21 +167,17 @@ do { \
scm_i_thread_sleep_for_gc (); \
} while (0)
-SCM scm_i_create_thread (scm_t_catch_body body, void *body_data,
- scm_t_catch_handler handler, void *handler_data,
- SCM protects);
-
-/* The C versions of the Scheme-visible thread functions. */
SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler);
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);
@@ -229,20 +190,39 @@ SCM_API SCM scm_all_threads (void);
SCM_API int scm_c_thread_exited_p (SCM thread);
SCM_API SCM scm_thread_exited_p (SCM thread);
-SCM_API scm_root_state *scm_i_thread_root (SCM thread);
+SCM_API void scm_frame_critical_section (void);
+
+#define SCM_I_CURRENT_THREAD \
+ ((scm_i_thread *) scm_i_pthread_getspecific (scm_i_thread_key))
+SCM_API scm_i_pthread_key_t scm_i_thread_key;
+
+#define scm_i_dynwinds() (SCM_I_CURRENT_THREAD->dynwinds)
+#define scm_i_set_dynwinds(w) (SCM_I_CURRENT_THREAD->dynwinds = (w))
+#define scm_i_last_debug_frame() (SCM_I_CURRENT_THREAD->last_debug_frame)
+#define scm_i_set_last_debug_frame(f) \
+ (SCM_I_CURRENT_THREAD->last_debug_frame = (f))
-#define SCM_CURRENT_THREAD \
- ((scm_thread *) scm_i_plugin_getspecific (scm_i_thread_key))
-extern scm_t_key scm_i_thread_key;
+SCM_API scm_i_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.
+*/
+
+#if SCM_USE_PTHREAD_THREADS
+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);
+#endif
+
+/* More convenience functions.
+ */
-SCM_API scm_t_mutex scm_i_misc_mutex;
+SCM_API unsigned int scm_std_sleep (unsigned int);
+SCM_API unsigned long scm_std_usleep (unsigned long);
#endif /* SCM_THREADS_H */
diff --git a/libguile/throw.c b/libguile/throw.c
index b5bbbaefe..8547fb2f7 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -33,9 +33,9 @@
#include "libguile/fluids.h"
#include "libguile/ports.h"
#include "libguile/lang.h"
-
#include "libguile/validate.h"
#include "libguile/throw.h"
+#include "libguile/init.h"
/* the jump buffer data structure */
@@ -68,13 +68,13 @@ static SCM
make_jmpbuf (void)
{
SCM answer;
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
{
SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
SETJBJMPBUF(answer, (jmp_buf *)0);
DEACTIVATEJB(answer);
}
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return answer;
}
@@ -145,9 +145,9 @@ scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch
jmpbuf = make_jmpbuf ();
answer = SCM_EOL;
- scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
+ scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
SETJBJMPBUF(jmpbuf, &jbr.buf);
- SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
+ SCM_SETJBDFRAME(jmpbuf, scm_i_last_debug_frame ());
if (setjmp (jbr.buf))
{
SCM throw_tag;
@@ -156,10 +156,10 @@ scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch
#ifdef STACK_CHECKING
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
DEACTIVATEJB (jmpbuf);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
throw_args = jbr.retval;
throw_tag = jbr.throw_tag;
jbr.throw_tag = SCM_EOL;
@@ -170,10 +170,10 @@ scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch
{
ACTIVATEJB (jmpbuf);
answer = body (body_data);
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
DEACTIVATEJB (jmpbuf);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
}
return answer;
}
@@ -241,15 +241,15 @@ scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_
c.handler_data = handler_data;
lazy_catch = make_lazy_catch (&c);
- SCM_REDEFER_INTS;
- scm_dynwinds = scm_acons (tag, lazy_catch, scm_dynwinds);
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_START;
+ scm_i_set_dynwinds (scm_acons (tag, lazy_catch, scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
answer = (*body) (body_data);
- SCM_REDEFER_INTS;
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_START;
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
return answer;
}
@@ -385,7 +385,7 @@ static void
handler_message (void *handler_data, SCM tag, SCM args)
{
char *prog_name = (char *) handler_data;
- SCM p = scm_cur_errp;
+ SCM p = scm_current_error_port ();
if (scm_ilength (args) == 4)
{
@@ -455,12 +455,10 @@ SCM
scm_handle_by_message (void *handler_data, SCM tag, SCM args)
{
if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
- {
- exit (scm_exit_status (args));
- }
+ exit (scm_exit_status (args));
handler_message (handler_data, tag, args);
- exit (2);
+ scm_i_pthread_exit (NULL);
}
@@ -471,6 +469,9 @@ scm_handle_by_message (void *handler_data, SCM tag, SCM args)
SCM
scm_handle_by_message_noexit (void *handler_data, SCM tag, SCM args)
{
+ if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
+ exit (scm_exit_status (args));
+
handler_message (handler_data, tag, args);
return SCM_BOOL_F;
@@ -587,7 +588,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
/* Search the wind list for an appropriate catch.
"Waiter, please bring us the wind list." */
- for (winds = scm_dynwinds; scm_is_pair (winds); winds = SCM_CDR (winds))
+ for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = SCM_CDR (winds))
{
dynpair = SCM_CAR (winds);
if (scm_is_pair (dynpair))
@@ -614,7 +615,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
jmpbuf = SCM_CDR (dynpair);
- for (wind_goal = scm_dynwinds;
+ for (wind_goal = scm_i_dynwinds ();
!scm_is_eq (SCM_CDAR (wind_goal), jmpbuf);
wind_goal = SCM_CDR (wind_goal))
;
@@ -625,12 +626,12 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
{
struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (jmpbuf);
SCM handle, answer;
- scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds)
+ scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
- scm_ilength (wind_goal)));
- SCM_REDEFER_INTS;
- handle = scm_dynwinds;
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_START;
+ handle = scm_i_dynwinds ();
+ scm_i_set_dynwinds (SCM_CDR (handle));
+ SCM_CRITICAL_SECTION_END;
answer = (c->handler) (c->handler_data, key, args);
scm_misc_error ("throw", "lazy-catch handler did return.", SCM_EOL);
}
@@ -639,12 +640,12 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
else if (SCM_JMPBUFP (jmpbuf))
{
struct jmp_buf_and_retval * jbr;
- scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds)
+ scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
- scm_ilength (wind_goal)));
jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
jbr->throw_tag = key;
jbr->retval = args;
- scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
+ scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf));
longjmp (*JBJMPBUF (jmpbuf), 1);
}
diff --git a/libguile/unif.c b/libguile/unif.c
index 3690ec74a..530da72f5 100644
--- a/libguile/unif.c
+++ b/libguile/unif.c
@@ -1353,7 +1353,7 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
#define FUNC_NAME s_scm_uniform_array_read_x
{
if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_cur_inp;
+ port_or_fd = scm_current_input_port ();
if (scm_is_uniform_vector (ura))
{
@@ -1407,7 +1407,7 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
#define FUNC_NAME s_scm_uniform_array_write
{
if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_cur_outp;
+ port_or_fd = scm_current_output_port ();
if (scm_is_uniform_vector (ura))
{
diff --git a/libguile/validate.h b/libguile/validate.h
index 1810be120..60c19c4fb 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -336,7 +336,8 @@
#define SCM_VALIDATE_OPOUTSTRPORT(pos, port) \
SCM_MAKE_VALIDATE_MSG (pos, port, OPOUTSTRPORTP, "open output string port")
-#define SCM_VALIDATE_FLUID(pos, fluid) SCM_MAKE_VALIDATE_MSG (pos, fluid, FLUIDP, "fluid")
+#define SCM_VALIDATE_FLUID(pos, fluid) \
+ SCM_I_MAKE_VALIDATE_MSG2 (pos, fluid, scm_is_fluid, "fluid")
#define SCM_VALIDATE_KEYWORD(pos, v) SCM_MAKE_VALIDATE_MSG (pos, v, KEYWORDP, "keyword")
diff --git a/libguile/vports.c b/libguile/vports.c
index 9e248e65e..b43102094 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -194,14 +194,14 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0,
SCM_ASSERT ((vlen == 5) || (vlen == 6), pv, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, modes);
- scm_mutex_lock (&scm_i_port_table_mutex);
+ scm_i_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);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
return z;
}
#undef FUNC_NAME