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