mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +02:00
Code Activity

See ChangeLog from 2005-03-02.

Browse source
This commit is contained in:
Marius Vollmer 2005-03-02 20:42:01 +00:00
parent cb1cfc42a4
commit 9de87eea47
67 changed files with 3044 additions and 2606 deletions
Download patch file Download diff file Expand all files Collapse all files

216
libguile/ChangeLog
View file

@ -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

71
libguile/__scm.h
View file

@ -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
**
**/

195
libguile/async.c
View file

@ -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
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 = 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 = 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))
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);
}

7
libguile/async.h
View file

@ -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)

15
libguile/backtrace.c
View file

@ -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;
}

139
libguile/continuations.c
View file

@ -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,14 +287,13 @@ 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_MISC_ERROR
("invoking continuation would cross continuation barrier: ~A",
scm_list_1 (cont));
}
@ -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 ()

19
libguile/continuations.h
View file

@ -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;
@ -83,13 +82,21 @@ typedef struct
#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_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 */

0
libguile/coop-threads.c
View file

14
libguile/debug.c
View file

@ -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;
}

103
libguile/deprecated.c
View file

@ -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 ()
{

56
libguile/deprecated.h
View file

@ -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

7
libguile/discouraged.h
View file

@ -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);

8
libguile/dynl.c
View file

@ -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 *

40
libguile/dynwind.c
View file

@ -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))
{

5
libguile/error.c
View file

@ -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)));

157
libguile/eval.c
View file

@ -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;
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_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);
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);

3
libguile/eval.h
View file

@ -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

2
libguile/filesys.c
View file

@ -1259,7 +1259,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
}
{
int rv = scm_internal_select (max_fd + 1,
int rv = scm_std_select (max_fd + 1,
&read_set, &write_set, &except_set,
time_ptr);
if (rv < 0)

433
libguile/fluids.c
View file

@ -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
SCM
scm_i_make_initial_fluids ()
{
return scm_c_make_vector (INITIAL_FLUIDS, SCM_BOOL_F);
}
/* 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.
*/
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
grow_fluids (scm_root_state *root_state, int new_length)
ensure_state_size (SCM state)
{
SCM old_fluids, new_fluids;
long old_length, i;
SCM fluids = DYNAMIC_STATE_FLUIDS (state);
size_t len = SCM_SIMPLE_VECTOR_LENGTH (fluids), i;
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)
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 (old_fluids, i));
i++;
SCM_SIMPLE_VECTOR_REF (fluids, i));
SET_DYNAMIC_STATE_FLUIDS (state, new_fluids);
}
while (i < new_length)
{
SCM_SIMPLE_VECTOR_SET (new_fluids, i, SCM_BOOL_F);
i++;
}
root_state->fluids = new_fluids;
/* Make sure that all states have the right size. This must be called
while fluid_admin_mutex is held.
*/
static void
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 ();
}
void
scm_i_copy_fluids (scm_root_state *root_state)
/* 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)
{
grow_fluids (root_state, SCM_SIMPLE_VECTOR_LENGTH (root_state->fluids));
SCM *statep, *fluidp;
/* Scan all fluids and deallocate the unmarked ones.
*/
fluidp = &all_fluids;
while (!scm_is_null (*fluidp))
{
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);
}
/* 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))
{
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);
}
}
return NULL;
}
static size_t
fluid_free (SCM fluid)
{
/* 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"
}

63
libguile/fluids.h
View file

@ -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 */

10
libguile/fports.c
View file

@ -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);
}

59
libguile/futures.c
View file

@ -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 ()
{

4
libguile/futures.h
View file

@ -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;

6
libguile/gc-freelist.c
View file

@ -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,

20
libguile/gc-malloc.c
View file

@ -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.");
}
/*
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);
}
}

94
libguile/gc.c
View file

@ -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,12 +930,18 @@ 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
#ifdef HAVE_ON_EXIT
on_exit (cleanup, 0);
#endif
#endif
#endif
scm_stand_in_procs = scm_c_make_hash_table (257);
@ -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);

22
libguile/gc.h
View file

@ -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;

4
libguile/gh.h
View file

@ -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,

8
libguile/goops.c
View file

@ -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

29
libguile/guardians.c
View file

@ -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;

182
libguile/init.c
View file

@ -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,
scm_set_current_input_port
(scm_standard_stream_to_port (0,
isatty (0) ? "r0" : "r",
"standard input");
scm_cur_outp = scm_standard_stream_to_port (1,
"standard input"));
scm_set_current_output_port
(scm_standard_stream_to_port (1,
isatty (1) ? "w0" : "w",
"standard output");
scm_cur_errp = scm_standard_stream_to_port (2,
"standard output"));
scm_set_current_error_port
(scm_standard_stream_to_port (2,
isatty (2) ? "w0" : "w",
"standard error");
scm_cur_loadp = SCM_BOOL_F;
"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);
}
static void *
invoke_main_func (void *body_data)
{
struct main_func_closure *closure = (struct main_func_closure *) body_data;
scm_set_program_arguments (closure->argc, closure->argv, 0);
(*closure->main_func) (closure->closure, closure->argc, closure->argv);
scm_restore_signals ();
/* This tick gives any pending
* asyncs a chance to run. This must be done after
* the call to scm_restore_signals.
*/
SCM_ASYNC_TICK;
/* If the caller doesn't want this, they should exit from main_func
themselves.
*/
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
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_init_guile ()
{
scm_init_guile_1 ((SCM_STACKITEM *)scm_get_stack_base ());
}
int scm_initialized_p = 0;
static void
scm_init_guile_1 (SCM_STACKITEM *base)
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"

4
libguile/init.h
View file

@ -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 */

4
libguile/ioext.c
View file

@ -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

12
libguile/iselect.h
View file

@ -52,22 +52,12 @@
#endif /* no FD_SET */
SCM_API int scm_internal_select (int fds,
SCM_API int scm_std_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);
#endif /* SCM_ISELECT_H */
/*

4
libguile/keywords.c
View file

@ -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

325
libguile/null-threads.c
View file

@ -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)
static void
destroy_keys (void)
{
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));
scm_i_pthread_key_t *key;
int again;
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)
do {
again = 0;
for (key = all_keys; key; key = key->next)
if (key->value && key->destr_func)
{
/* 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
void *v = key->value;
key->value = NULL;
key->destr_func (v);
again = 1;
}
SCM_MARK_BACKING_STORE();
} while (again);
}
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
scm_i_pthread_key_create (scm_i_pthread_key_t *key,
void (*destr_func) (void *))
{
if (all_keys == NULL)
atexit (destroy_keys);
key->next = all_keys;
all_keys = key;
key->value = NULL;
key->destr_func = destr_func;
return 0;
}
#undef FUNC_NAME
SCM
scm_yield (void)
{
return SCM_BOOL_T;
}
#endif /* SCM_USE_NULL_THREADS */
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;
{
/* 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_unlock_mutex (m);
while (!cv->signalled)
{
if (SCM_UNBNDP (t))
select (0, NULL, NULL, NULL, NULL);
else
{
struct timeval now, then, diff;
then = waittime;
gettimeofday (&now, NULL);
if (timeval_subtract (&diff, &then, &now))
break;
select (0, NULL, NULL, NULL, &diff);
}
SCM_ASYNC_TICK;
}
scm_lock_mutex (m);
if (cv->signalled)
{
cv->signalled = 0;
return SCM_BOOL_T;
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM
scm_signal_condition_variable (SCM c)
{
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;
}
SCM
scm_broadcast_condition_variable (SCM c)
{
return scm_signal_condition_variable (c); /* only one thread anyway. */
}
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... :) */
}
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;
}
/*
Local Variables:

144
libguile/null-threads.h
View file

@ -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.
/* 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.
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.
*/
#error temporarily broken, compile with threads enabled (default option)
#include <errno.h>
/* We can't switch so don't bother trying.
/* Threads
*/
#undef SCM_THREAD_SWITCHING_CODE
#define SCM_THREAD_SWITCHING_CODE
#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
#define scm_t_thread int
/* The "(void)(...)" constructs in the expansions are there to ensure
that the side effects of the argument expressions take place.
/* 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
/* 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))--)
#define scm_t_mutex int
/* 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)
#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*)); \
/* 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)
#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
/* 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;
/* These are the actual prototypes of the functions/macros defined
above. We list them here for reference. */
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)
typedef int scm_t_thread;
/* 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
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);
SCM_API int scm_thread_select (int nfds,
SELECT_TYPE *readfds,
SELECT_TYPE *writefds,
SELECT_TYPE *exceptfds,
struct timeval *timeout);
#endif
#endif /* SCM_NULL_THREADS_H */

4
libguile/objprop.c
View file

@ -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

132
libguile/ports.c
View file

@ -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
{
scm_frame_current_foo_port (port,
scm_current_error_port,
scm_set_current_error_port);
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_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"
}

3
libguile/ports.h
View file

@ -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 */

12
libguile/posix.c
View file

@ -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));

28
libguile/print.c
View file

@ -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);

96
libguile/pthread-threads.h
View file

@ -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
/* The scm_t_ types are temporarily used both in plugin and low-level API */
#define scm_t_thread pthread_t
/* Signals
*/
#define scm_i_pthread_sigmask pthread_sigmask
#define scm_i_plugin_thread_create pthread_create
/* 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
#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
/* 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
extern scm_t_mutexattr scm_i_plugin_mutex; /* The "fast" mutex. */
/* 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
#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))
/* 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
extern scm_t_mutexattr scm_i_plugin_rec_mutex;
/* 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
#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
#ifdef SCM_DEBUG_THREADS
void scm_i_assert_heap_locked (void);
#endif
void scm_init_pthread_threads (void);
#endif /* SCM_THREADS_PTHREADS_H */
#endif /* SCM_PTHREADS_THREADS_H */
/*
Local Variables:

4
libguile/rdelim.c
View file

@ -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);

2
libguile/read.c
View file

@ -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);

4
libguile/regex-posix.c
View file

@ -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,

165
libguile/root.c
View file

@ -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;
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_internal_catch (SCM_BOOL_T,
body, body_data,
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"
}

60
libguile/root.h
View file

@ -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,

6
libguile/rw.c
View file

@ -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;

259
libguile/scmsigs.c
View file

@ -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,34 +98,6 @@ static struct sigaction orig_handlers[NSIG];
static SIGRETTYPE (*orig_handlers[NSIG])(int);
#endif
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;
}
}
#ifndef HAVE_SIGACTION
signal (signum, take_signal);
#endif
}
SCM
scm_sigaction (SCM signum, SCM handler, SCM flags)
{
return scm_sigaction_for_thread (signum, handler, flags, SCM_UNDEFINED);
}
static SCM
close_1 (SCM proc, SCM arg)
{
@ -129,129 +105,121 @@ close_1 (SCM proc, SCM arg)
scm_list_2 (proc, arg)));
}
/* 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).
*/
#if SCM_USE_PTHREAD_THREADS
struct install_handler_data {
int signum;
SCM thread;
SCM handler;
};
static int signal_pipe[2];
static SIGRETTYPE
take_signal (int signum)
{
char sigbyte = signum;
write (signal_pipe[1], &sigbyte, 1);
#ifndef HAVE_SIGACTION
signal (signum, take_signal);
#endif
}
static SCM
scm_delq_spine_x (SCM cell, SCM list)
signal_delivery_thread (void *data)
{
SCM s = list, prev = SCM_BOOL_F;
sigset_t all_sigs;
scm_t_guile_ticket ticket;
int n, sig;
char sigbyte;
while (!scm_is_eq (cell, s))
sigfillset (&all_sigs);
scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
while (1)
{
if (scm_is_null (s))
return list;
prev = s;
s = SCM_CDR (s);
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);
}
if (scm_is_false (prev))
return SCM_CDR (cell);
else
{
SCM_SETCDR (prev, SCM_CDR (cell));
return list;
else if (n < 0 && errno != EINTR)
perror ("error in signal delivery thread");
}
}
static void *
really_install_handler (void *data)
static void
start_signal_delivery_thread (void)
{
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);
if (pipe (signal_pipe) != 0)
scm_syserror (NULL);
scm_spawn_thread (signal_delivery_thread, NULL,
scm_handle_by_message, "signal delivery thread");
}
/* 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))
static void
ensure_signal_delivery_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);
static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
scm_i_pthread_once (&once, start_signal_delivery_thread);
}
/* Set the new handler. */
if (scm_is_false (handler))
#else /* !SCM_USE_PTHREAD_THREADS */
static SIGRETTYPE
take_signal (int signum)
{
SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, SCM_BOOL_F);
SCM_SIMPLE_VECTOR_SET (signal_cell_handlers, signum, SCM_BOOL_F);
}
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_SIMPLE_VECTOR_SET (*signal_handlers, signum, handler);
SCM_SIMPLE_VECTOR_SET (signal_cell_handlers, signum,
close_1 (handler, scm_from_int (signum)));
SCM_SETCDR (cell, t->active_asyncs);
t->active_asyncs = cell;
t->pending_asyncs = 1;
}
/* 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;
#ifndef HAVE_SIGACTION
signal (signum, take_signal);
#endif
}
static void
ensure_signal_delivery_thread ()
{
return;
}
#endif /* !SCM_USE_PTHREAD_THREADS */
static void
install_handler (int signum, SCM thread, SCM handler)
{
/* 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.
*/
if (scm_is_false (handler))
{
SCM_SIMPLE_VECTOR_SET (*signal_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_handler_asyncs, signum, async);
}
struct install_handler_data args;
args.signum = signum;
args.thread = thread;
args.handler = handler;
scm_c_call_with_blocked_asyncs (really_install_handler, &args);
SCM_SIMPLE_VECTOR_SET (signal_handler_threads, signum, thread);
}
SCM
scm_sigaction (SCM signum, SCM handler, SCM flags)
{
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));

4
libguile/smob.c
View file

@ -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);

4
libguile/srcprop.c
View file

@ -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);
}

4
libguile/srfi-4.c
View file

@ -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)),

21
libguile/stackchk.c
View file

@ -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 ()
{

4
libguile/stackchk.h
View file

@ -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\
{\

4
libguile/stacks.c
View file

@ -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))
{

34
libguile/stime.c
View file

@ -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

26
libguile/strings.c
View file

@ -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);
}

4
libguile/strports.c
View file

@ -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)

8
libguile/struct.c
View file

@ -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

4
libguile/symbols.c
View file

@ -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);

1818
libguile/threads.c
View file

File diff suppressed because it is too large Load diff

288
libguile/threads.h
View file

@ -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))
typedef struct scm_i_thread {
struct scm_i_thread *next_thread;
#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))
SCM handle;
scm_i_pthread_t pthread;
#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))
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
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);
#define scm_mutex_init scm_i_plugin_mutex_init
#define scm_mutex_destroy scm_i_plugin_mutex_destroy
SCM_API int scm_mutex_lock (scm_t_mutex *m);
#define scm_mutex_trylock scm_i_plugin_mutex_trylock
#define scm_mutex_unlock scm_i_plugin_mutex_unlock
/* Guile itself needs recursive mutexes. See for example the
implentation of scm_force in eval.c.
Note that scm_rec_mutex_lock et al can be replaced by direct usage
of the corresponding pthread functions if we use the pthread
debugging API to access the stack top (in which case there is no
longer any need to save the top of the stack before blocking).
It's therefore highly motivated to use these calls in situations
where Guile or the application needs recursive mutexes.
*/
#define scm_rec_mutex_init scm_i_plugin_rec_mutex_init
#define scm_rec_mutex_destroy scm_i_plugin_rec_mutex_destroy
/* It's a safer bet to use the following functions.
The future of the _init functions is uncertain.
*/
SCM_API scm_t_rec_mutex *scm_make_rec_mutex (void);
SCM_API void scm_rec_mutex_free (scm_t_rec_mutex *);
SCM_API int scm_rec_mutex_lock (scm_t_rec_mutex *m);
#define scm_rec_mutex_trylock scm_i_plugin_rec_mutex_trylock
#define scm_rec_mutex_unlock scm_i_plugin_rec_mutex_unlock
#define scm_cond_init scm_i_plugin_cond_init
#define scm_cond_destroy scm_i_plugin_cond_destroy
SCM_API int scm_cond_wait (scm_t_cond *c, scm_t_mutex *m);
SCM_API int scm_cond_timedwait (scm_t_cond *c,
scm_t_mutex *m,
const scm_t_timespec *t);
#define scm_cond_signal scm_i_plugin_cond_signal
#define scm_cond_broadcast scm_i_plugin_cond_broadcast
#define scm_key_create scm_i_plugin_key_create
#define scm_key_delete scm_i_plugin_key_delete
SCM_API int scm_setspecific (scm_t_key k, void *s);
SCM_API void *scm_getspecific (scm_t_key k);
#define scm_thread_select scm_internal_select
/* The application must scm_leave_guile() before entering any piece of
code which can
1. block, or
2. execute for any longer period of time without calling SCM_TICK
Note, though, that it is *not* necessary to use these calls
together with any call in this API.
*/
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_CURRENT_THREAD \
((scm_thread *) scm_i_plugin_getspecific (scm_i_thread_key))
extern scm_t_key scm_i_thread_key;
#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;
/* 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 *);
#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))
SCM_API scm_t_mutex scm_i_misc_mutex;
SCM_API scm_i_pthread_mutex_t scm_i_misc_mutex;
/* 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 unsigned int scm_std_sleep (unsigned int);
SCM_API unsigned long scm_std_usleep (unsigned long);
#endif /* SCM_THREADS_H */

61
libguile/throw.c
View file

@ -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));
}
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);
}

4
libguile/unif.c
View file

@ -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))
{

3
libguile/validate.h
View file

@ -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")

4
libguile/vports.c
View file

@ -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