See ChangeLog from 2005-03-02.

libguile/ChangeLog

@@ -1,3 +1,219 @@
+2005-03-02  Marius Vollmer  <marius.vollmer@uni-dortmund.de>
+
+	Big merge from the mvo-thread-cleanup branch. The main changes
+	are:
+	
+	- The dynamic roots functionality has been split into dynamic
+	  states and continuations barriers.  Fluids have been
+	  reimplemented and can now be garbage collected.
+	
+	- Initialization of Guile now works in a multi-thread friendly
+	  manner.  Threads can freely enter and leave guile mode.
+
+	- Blocking on mutexes or condition variables or while selecting
+	  can now be reliably interrupted via system asyncs.
+
+	- The low-level threading interface has been removed.
+
+	- Signals are delivered via a pipe to a dedicated 'signal delivery
+	  thread'.
+	
+	- SCM_DEFER_INTS, SCM_ALLOW_INTS etc have been deprecated.
+
+	* throw.c (scm_handle_by_message): Exit only the current thread,
+	not the whole process.
+	(scm_handle_by_message_noexit): Exit when catching 'quit.
+	
+	* scmsigs.c (take_signal, signal_delivery_thread,
+	start_signal_delivery_thread, ensure_signal_delivery_thread,
+	install_handler): Reimplemented signal delivery as explained in
+	the comments.
+
+	* pthreads-threads.h (scm_i_pthread_t, scm_i_pthread_self,
+	scm_i_pthread_create, scm_i_pthread_detach, scm_i_pthread_exit,
+	scm_i_sched_yield, scm_i_pthread_sigmask,
+	SCM_I_PTHREAD_MUTEX_INITIALIZER,
+	SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER, scm_i_pthread_mutex_t ,
+	scm_i_pthread_mutex_init, scm_i_pthread_mutex_destroy,
+	scm_i_pthread_mutex_trylock, scm_i_pthread_mutex_lock,
+	scm_i_pthread_mutex_unlock, SCM_I_PTHREAD_COND_INITIALIZER,
+	scm_i_pthread_cond_t, scm_i_pthread_cond_init,
+	scm_i_pthread_cond_destroy, scm_i_pthread_cond_signal,
+	scm_i_pthread_cond_broadcast, scm_i_pthread_cond_wait,
+	scm_i_pthread_cond_timedwait, scm_i_pthread_once_t,
+	SCM_I_PTHREAD_ONCE_INIT, scm_i_pthread_once, scm_i_pthread_key_t ,
+	scm_i_pthread_key_create, scm_i_pthread_setspecific,
+	scm_i_pthread_getspecific, scm_i_scm_pthread_mutex_lock,
+	scm_i_frame_pthread_mutex_lock, scm_i_scm_pthread_cond_wait,
+	scm_i_scm_pthread_cond_timedwait): Provide the obvious mapping
+	when using pthreads.
+	* null-threads.c, null-threads.h: Provide dummy definitions for
+	the above symbols when not using pthreads.
+	
+	* modules.h, modules.c (scm_frame_current_module): New.
+
+	* load.c (scm_primitive_load): Use scm_i_frame_current_load_port
+	instead of scm_internal_dynamic_wind.
+
+	* init.h, init.c (restart_stack, start_stack): Removed.
+	(scm_boot_guile, invoke_main_func): Simply use scm_with_guile.
+	(scm_boot_guile_1): Removed.
+	(scm_i_init_mutex): New.
+	(really_cleanup_for_exit, cleanup_for_exit): New.
+	(scm_init_guile_1, scm_i_init_guile): Renamed former to latter.
+	Moved around some init funcs.  Call
+	scm_init_threads_default_dynamic_state.  Register cleanup_for_exit
+	with atexit.
+	
+	* hashtab.c (scm_hash_fn_create_handle_x, scm_hash_fn_remove_x):
+	Use "!scm_is_eq" instead of "!=".
+
+	* ge-scmconfig.c, gen-scmconfig.h.in (SCM_I_GSC_USE_COOP_THREADS,
+	SCM_USE_COOP_THREADS): Removed.
+
+	* gc.c (scm_igc): Take care that scm_gc_running_p is properly
+	maintained.  Unlock scm_i_sweep_mutex before running
+	scm_after_gc_c_hook.
+	(scm_permanent_object): Allocate outside of critical section.
+	(cleanup): Removed.
+	
+	* fluids.h, fluids.c: Reimplemented completely.
+	(SCM_FLUID_NUM, SCM_FAST_FLUID_REF,
+	SCM_FAST_FLUID_SET): Reimplemented as functions.
+	(scm_is_fluid): New.
+	(scm_i_make_initial_fluids, scm_i_copy_fluids): Removed.
+	(scm_make_dynamic_state, scm_dynamic_state_p,
+	scm_is_dynamic_state, scm_current_dynamic_state,
+	scm_set_current_dynamic_state, scm_frame_current_dynamic_state,
+	scm_c_with_dynamic_state, scm_with_dynamic_state,
+	scm_i_make_initial_dynamic_state, scm_fluids_prehistory): New.
+	
+	* feature.c (progargs_fluid): New.
+	(scm_program_arguments, scm_set_program_arguments): Use it instead
+	of scm_progargs.
+	(scm_init_feature): Allocate it.  Also, only add "threads" feature
+	when SCM_USE_PTHREAD_THREADS is true.
+	
+	* eval.c (scm_makprom): Use scm_make_recursive_mutex instead of
+	scm_make_rec_mutex, with all the consequences.
+	(scm_eval_x, scm_eval): Use scm_frame_begin etc instead of
+	scm_internal_dynamic_wind.  Handle dynamic states as second
+	argument.
+	
+        * threads.h, threads.c (scm_internal_select): Renamed to
+	scm_std_select and discouraged old name.
+	(scm_thread_sleep, scm_thread_usleep): Likewise, as scm_std_sleep
+	and scm_std_usleep.
+	(scm_tc16_fair_mutex, scm_tc16_fair_condvar, SCM_MUTEXP,
+	SCM_FAIR_MUTEX_P, SCM_MUTEX_DATA, SCM_CONDVARP,
+	SCM_FAIR_CONDVAR_P, SCM_CONDVAR_DATA, SCM_THREADP,
+	SCM_THREAD_DATA): Removed.
+	(SCM_I_IS_THREAD, SCM_I_THREAD_DATA): New.
+	(scm_i_thread): New.
+	(SCM_VALIDATE_THREAD, SCM_VALIDATE_MUTEX, SCM_VALIDATE_CONDVAR):
+	Use scm_assert_smob_type.
+	(scm_c_scm2thread, scm_thread_join, scm_thread_detach,
+	scm_thread_self, scm_thread_yield, scm_mutex_init,
+	scm_mutex_destroy, scm_mutex_trylock, scm_mutex_unlock,
+	scm_rec_mutex_init, scm_rec_mutex_destroy, scm_make_rec_mutex,
+	scm_rec_mutex_free, scm_rec_mutex_lock, scm_rec_mutex_trylock,
+	scm_cond_init, scm_cond_destroy, scm_cond_wait,
+	scm_cond_timedwait, scm_cond_signal, scm_cond_broadcast,
+	scm_key_create, scm_key_delete, scm_setspecific, scm_getspecific,
+	scm_thread_select): Removed.  Replaced with scm_i_pthread
+	functions as appropriate.
+	(scm_in_guile, scm_outside_guile): Removed.
+	(scm_t_guile_ticket, scm_leave_guile, scm_enter_guile): Return and
+	take a ticket.
+	(scm_with_guile, scm_without_guile, scm_i_with_guile_and_parent):
+	New.
+	(scm_i_frame_single_threaded): New.
+	(scm_init_threads_default_dynamic_state): New.
+	(scm_i_create_thread): Removed.
+	(scm_make_fair_mutex, scm_make_fair_condition_variable): Removed.
+	(scm_make_recursive_mutex): New.
+	(scm_frame_critical_section): New.
+	(SCM_CURRENT_THREAD, SCM_I_CURRENT_THREAD): Renamed former to
+	latter, changed all uses.
+	(scm_i_dynwinds, scm_i_setdynwinds, scm_i_last_debug_frame,
+	scm_i_set_last_debug_frame): New, use them instead of scm_root
+	stuff.
+	(SCM_THREAD_LOCAL_DATA, SCM_SET_THREAD_LOCAL_DATA,
+	scm_i_root_state_key,m scm_i_set_thread_data): Removed.
+	(scm_pthread_mutex_lock, scm_frame_pthread_mutex_lock,
+	scm_pthread_cond_wait, scm_pthread_cond_timedwait).
+	(remqueue): Allow the removal of already removed cells.  Indicate
+	whether a real removal has happened.
+	(scm_thread): Removed, replaced with scm_i_thread.
+	(make_thread, init_thread_creatant): Removed.
+	(cur_thread): Removed.
+	(block_self, unblock_from_queue): New.
+	(block, timed_block, unblock): Removed.
+	(guilify_self_1, guilify_self_2, do_thread_exit,
+	init_thread_key_once, init_thread_key,
+	scm_i_init_thread_for_guile, get_thread_stack_base,
+	scm_init_guile): New initialisation method.
+	(scm_call_with_new_thread, scm_spawn_thread): Use it to simplify
+	thread creation.
+	(fair_mutex, fat_mutex, etc, fair_condvar, fat_condvar): Renamed
+	"fair" to fat and implemented new semantics, including reliable
+	interruption.
+	(all_threads): Now a pointer to a scm_i_thread, not a SCM.
+	(scm_threads_mark_stacks): Explicitly mark handle.
+	(scm_std_select): Allow interruption by also selecting on the
+	sleep_pipe.
+	(scm_i_thread_put_to_sleep): Handle recursive requests for
+	single-threadedness.
+	(scm_threads_prehistory, scm_init_threads): Put current thread
+	into guile mode via guileify_self_1 and guileify_self_2,
+	respectively.
+
+	* fluid.h (SCM_FLUIDP): Deprecated.
+	
+	* coop-threads.c: Removed.
+	
+	* continuations.h, continuations.c (scm_with_continuation_barrier,
+	scm_c_with_continuation_barrier, scm_i_with_continuation_barrier):
+	New.
+
+	* async.h, async.c (scm_i_setup_sleep, scm_i_reset_sleep): New.
+	(async_mutex): New.
+	(scm_async_click): Protected with async_mutex.  Do not deal with
+	signal_asyncs, which are gone.  Set cdr of handled async cell to
+	#f.
+	(scm_i_queue_async_cell): Protected with async_mutex.  Interrupt
+	current sleep.
+	(scm_system_async_mark_for_thread): Do not use scm_current_thread
+	since that might not work during early initialization.
+	
+	* __scm.h (SCM_DEFER_INTS, SCM_ALLOW_INTS, SCM_REDEFER_INTS,
+	SCM_REALLOW_INTS): Deprecated by moving into deprecated.h and
+	deprecated.c.  Replaced all uses with SCM_CRITICAL_SECTION_START
+	and SCM_CRITICAL_SECTION_END.
+	(SCM_ENTER_A_SECTION, SCM_EXIT_A_SECTION): Removed.  Replaced with
+	SCM_CRITICAL_SECTION_START/END.
+	
+	* Makefile.am (modinclude_HEADER): Removed threads-plugin.h.
+	(libguile_la_SOURCES): Added null-threads.c
+	(EXTRA_libguile_la_SOURCES): Removed pthread-threads.c and
+	threads-plugin.c.
+	* pthread-threads.c, threads-plugin.c, threads-plugin.h: Removed.
+
+	* root.h, root.c (scm_tc16_root, SCM_ROOTP, SCM_ROOT_STATE,
+	scm_root_state, scm_stack_base, scm_save_regs_gc_mark,
+	scm_errjmp_bad, scm_rootcont, scm_dynwinds, scm_progargs,
+	scm_last_debug_frame, scm_exitval, scm_cur_inp, scm_outp,
+	scm_cur_err, scm_cur_loadp, scm_root, scm_set_root,
+	scm_make_root): Removed or deprecated.  Replaced with references
+	to the current thread, dynamic state, continuation barrier, or
+	some fluid, as appropriate.
+	(root_mark, root_print): Removed.
+	(scm_internal_cwdr): Reimplemented guts with
+	scm_frame_current_dynamic_state and
+	scm_i_with_continuation_barrier.
+	(scm_dynamic_root): Return current continuation barrier.
+	
+	
 2005-02-28  Marius Vollmer  <mvo@zagadka.de>
 
 	* socket.c (scm_setsockopt): Handle IP_ADD_MEMBERSHIP and

libguile/__scm.h

@@ -454,7 +454,7 @@ typedef long SCM_STACKITEM;
 
 #define SCM_ASYNC_TICK /*fixme* should change names */ \
 do { \
-  if (scm_root->pending_asyncs) \
+  if (SCM_I_CURRENT_THREAD->pending_asyncs) \
     scm_async_click (); \
 } while (0)
 
@@ -482,40 +482,6 @@ do { \
 #define SCM_FENCE
 #endif
 
-/* In the old days, SCM_DEFER_INTS stopped signal handlers from running,
-   since in those days the handler directly ran scheme code, and that had to
-   be avoided when the heap was not in a consistent state etc.  And since
-   the scheme code could do a stack swapping new continuation etc, signals
-   had to be deferred around various C library functions which were not safe
-   or not known to be safe to swap away, which was a lot of stuff.
-
-   These days signals are implemented with asyncs and don't directly run
-   scheme code in the handler, but hold it until an SCM_TICK etc where it
-   will be safe.  This means interrupt protection is not needed and
-   SCM_DEFER_INTS / SCM_ALLOW_INTS is something of an anachronism.
-
-   What past SCM_DEFER_INTS usage also did though was indicate code that was
-   not reentrant, ie. could not be reentered by signal handler code.  The
-   present definitions are a mutex lock, affording that reentrancy
-   protection against the new guile 1.8 free-running posix threads.
-
-   One big problem with the present defintions though is that code which
-   throws an error from within a DEFER/ALLOW region will leave the
-   defer_mutex locked and hence hang other threads that attempt to enter a
-   similar DEFER/ALLOW region.
-
-   The plan is to migrate reentrancy protection to an explicit mutex
-   (private or global, with unwind where necessary), and remove the
-   remaining DEFER/ALLOWs.  */
-
-#define SCM_DEFER_INTS scm_rec_mutex_lock (&scm_i_defer_mutex);
-
-#define SCM_ALLOW_INTS scm_rec_mutex_unlock (&scm_i_defer_mutex);
-
-#define SCM_REDEFER_INTS SCM_DEFER_INTS
-
-#define SCM_REALLOW_INTS SCM_ALLOW_INTS
-
 #define SCM_TICK \
 do { \
   SCM_ASYNC_TICK; \
@@ -524,41 +490,6 @@ do { \
 
 
 
-/* Note: The following needs updating. */
-
-/* Classification of critical sections
- *
- * When Guile moves to POSIX threads, it won't be possible to prevent
- * context switching.  In fact, the whole idea of context switching is
- * bogus if threads are run by different processors.  Therefore, we
- * must ultimately eliminate all critical sections or enforce them by
- * use of mutecis.
- *
- * All instances of SCM_DEFER_INTS and SCM_ALLOW_INTS should therefore
- * be classified and replaced by one of the delimiters below.  If you
- * understand what this is all about, I'd like to encourage you to
- * help with this task.  The set of classes below must of course be
- * incrementally augmented.
- *
- * MDJ 980419 <djurfeldt@nada.kth.se>
- */
-
-/* A sections
- *
- * Allocation of a cell with type tag in the CAR.
- *
- * With POSIX threads, each thread will have a private pool of free
- * cells.  Therefore, this type of section can be removed.  But!  It
- * is important that the CDR is initialized first (with the CAR still
- * indicating a free cell) so that we can guarantee a consistent heap
- * at all times.
- */
-
-#define SCM_ENTER_A_SECTION SCM_CRITICAL_SECTION_START
-#define SCM_EXIT_A_SECTION SCM_CRITICAL_SECTION_END
-
-
-
 /** SCM_ASSERT
  **
  **/

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;
+  scm_i_scm_pthread_mutex_lock (&async_mutex);
-  if (scm_root->block_asyncs == 0)
+  t->pending_asyncs = 0;
+  if (t->block_asyncs == 0)
     {
-      SCM asyncs;
+      asyncs = t->active_asyncs;
-      while (!scm_is_null(asyncs = scm_root->active_asyncs))
+      t->active_asyncs = SCM_EOL;
-	{
+    }
-	  scm_root->active_asyncs = SCM_EOL;
+  else
-	  do
+    asyncs = SCM_EOL;
-	    {
+  scm_i_pthread_mutex_unlock (&async_mutex);
-	      scm_call_0 (SCM_CAR (asyncs));
+
-	      asyncs = SCM_CDR (asyncs);
+  while (scm_is_pair (asyncs))
-	    }
+    {
-	  while (!scm_is_null(asyncs));
+      SCM next = SCM_CDR (asyncs);
-	}
+      SCM_SETCDR (asyncs, SCM_BOOL_F);
-      for (asyncs = scm_root->signal_asyncs; !scm_is_null(asyncs);
+      scm_call_0 (SCM_CAR (asyncs));
-	   asyncs = SCM_CDR (asyncs))
+      asyncs = next;
-	{
-	  if (scm_is_true (SCM_CAR (asyncs)))
-	    {
-	      SCM proc = SCM_CAR (asyncs);
-	      SCM_SETCAR (asyncs, SCM_BOOL_F);
-	      scm_call_0 (proc);
-	    }
-	}
     }
 }
 
@@ -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)
+  if (!scm_is_pair (p))
-    root->active_asyncs = c;
+    t->active_asyncs = c;
   else
     {
       SCM pp;
-      while ((pp = SCM_CDR(p)) != SCM_EOL)
+      while (scm_is_pair (pp = SCM_CDR (p)))
 	{
-	  if (SCM_CAR (p) == SCM_CAR (c))
+	  if (scm_is_eq (SCM_CAR (p), SCM_CAR (c)))
-	    return;
+	    {
+	      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_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t);
-			  scm_i_thread_root (thread));
   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_i_thread *)data)->block_asyncs == 0)
-  if (scm_root->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_i_thread *t = SCM_I_CURRENT_THREAD;
-  scm_frame_unwind_handler (decrease_block, NULL, SCM_F_WIND_EXPLICITLY);
+  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_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
-  scm_frame_unwind_handler (increase_block, NULL, SCM_F_WIND_EXPLICITLY);
+  scm_frame_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
 }
 
 

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)

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_newline (port);
-      scm_puts ("Backtrace:\n", scm_cur_outp);
+      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;
 }

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->root = thread->continuation_root;
-  continuation->seq = rootcont->seq;
+  continuation->dframe = scm_i_last_debug_frame ();
-  continuation->dframe = scm_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
+  if (continuation->root != thread->continuation_root)
-      /* this base comparison isn't needed */
-      || continuation->base != rootcont->base)
     {
-      SCM_MISC_ERROR ("continuation from wrong top level: ~S", 
+      SCM_MISC_ERROR 
-		      scm_list_1 (cont));
+	("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 ()

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_JMPBUF(x)		 ((SCM_CONTREGS (x))->jmpbuf)
-#define SCM_DYNENV(x)		((SCM_CONTREGS (x))->dynenv)
+#define SCM_DYNENV(x)		 ((SCM_CONTREGS (x))->dynenv)
-#define SCM_THROW_VALUE(x)	((SCM_CONTREGS (x))->throw_value)
+#define SCM_THROW_VALUE(x)	 ((SCM_CONTREGS (x))->throw_value)
-#define SCM_BASE(x)		((SCM_CONTREGS (x))->base) 
+#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)   
-#define SCM_SEQ(x)		((SCM_CONTREGS (x))->seq)   
+#define SCM_DFRAME(x)		 ((SCM_CONTREGS (x))->dframe)
-#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 */

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

libguile/deprecated.c

@@ -43,6 +43,7 @@
 #include "libguile/smob.h"
 #include "libguile/alist.h"
 #include "libguile/keywords.h"
+#include "libguile/feature.h"
 
 #include <stdio.h>
 #include <string.h>
@@ -199,7 +200,7 @@ SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0,
 {
   struct moddata *md1, *md2;
 
-  SCM_DEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
 
   for (md1 = registered_mods; md1; md1 = md2)
     {
@@ -208,7 +209,7 @@ SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0,
     }
   registered_mods = NULL;
 
-  SCM_ALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -687,7 +688,7 @@ scm_sym2ovcell_soft (SCM sym, SCM obarray)
   scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. "
 				   "Use hashtables instead.");
 
-  SCM_REDEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
   for (lsym = SCM_VECTOR_REF (obarray, hash);
        SCM_NIMP (lsym);
        lsym = SCM_CDR (lsym))
@@ -695,11 +696,11 @@ scm_sym2ovcell_soft (SCM sym, SCM obarray)
       z = SCM_CAR (lsym);
       if (scm_is_eq (SCM_CAR (z), sym))
 	{
-	  SCM_REALLOW_INTS;
+	  SCM_CRITICAL_SECTION_END;
 	  return z;
 	}
     }
-  SCM_REALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
   return SCM_BOOL_F;
 }
 
@@ -872,7 +873,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0,
   SCM_VALIDATE_VECTOR (1,o);
   hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
   /* If the symbol is already interned, simply return. */
-  SCM_REDEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
   {
     SCM lsym;
     SCM sym;
@@ -883,7 +884,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0,
 	sym = SCM_CAR (lsym);
 	if (scm_is_eq (SCM_CAR (sym), s))
 	  {
-	    SCM_REALLOW_INTS;
+	    SCM_CRITICAL_SECTION_END;
 	    return SCM_UNSPECIFIED;
 	  }
       }
@@ -891,7 +892,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0,
 		    scm_acons (s, SCM_UNDEFINED,
 			       SCM_VECTOR_REF (o, hval)));
   }
-  SCM_REALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -913,7 +914,7 @@ SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
     return SCM_BOOL_F;
   SCM_VALIDATE_VECTOR (1,o);
   hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
-  SCM_DEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
   {
     SCM lsym_follow;
     SCM lsym;
@@ -930,12 +931,12 @@ SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
 	      SCM_VECTOR_SET (o, hval, lsym);
 	    else
 	      SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
-	    SCM_ALLOW_INTS;
+	    SCM_CRITICAL_SECTION_END;
 	    return SCM_BOOL_T;
 	  }
       }
   }
-  SCM_ALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
   return SCM_BOOL_F;
 }
 #undef FUNC_NAME
@@ -1357,6 +1358,86 @@ scm_i_array_dims (SCM a)
   return SCM_I_ARRAY_DIMS (a);
 }
 
+SCM
+scm_i_cur_inp (void)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_cur_inp is deprecated.  Use scm_current_input_port instead.");
+  return scm_current_input_port ();
+}
+
+SCM
+scm_i_cur_outp (void)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_cur_outp is deprecated.  Use scm_current_output_port instead.");
+  return scm_current_output_port ();
+}
+
+SCM
+scm_i_cur_errp (void)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_cur_errp is deprecated.  Use scm_current_error_port instead.");
+  return scm_current_error_port ();
+}
+
+SCM
+scm_i_cur_loadp (void)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_cur_loadp is deprecated.  Use scm_current_load_port instead.");
+  return scm_current_load_port ();
+}
+
+SCM
+scm_i_progargs (void)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_progargs is deprecated.  Use scm_program_arguments instead.");
+  return scm_program_arguments ();
+}
+
+SCM
+scm_i_deprecated_dynwinds (void)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_dynwinds is deprecated.  Do not use it.");
+  return scm_i_dynwinds ();
+}
+
+scm_t_debug_frame *
+scm_i_deprecated_last_debug_frame (void)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_last_debug_frame is deprecated.  Do not use it.");
+  return scm_i_last_debug_frame ();
+}
+
+SCM_STACKITEM *
+scm_i_stack_base (void)
+{
+  scm_c_issue_deprecation_warning
+    ("scm_stack_base is deprecated.  Do not use it.");
+  return SCM_I_CURRENT_THREAD->base;
+}
+
+int
+scm_i_fluidp (SCM x)
+{
+  scm_c_issue_deprecation_warning
+    ("SCM_FLUIDP is deprecated.  Use scm_is_fluid instead.");
+  return scm_is_fluid (x);
+}
+
+void
+scm_i_defer_ints_etc ()
+{
+  scm_c_issue_deprecation_warning
+    ("SCM_CRITICAL_SECTION_START etc are deprecated.  "
+     "Use a mutex instead if appropriate.");
+}
+
 void
 scm_i_init_deprecated ()
 {

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

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

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
+  Guile does not currently support pre-emptive threads, so there is no
-  no mutex.  Previously SCM_DEFER_INTS and SCM_ALLOW_INTS were used:
+  mutex.  Previously SCM_CRITICAL_SECTION_START and
-  they are mentioned here in case somebody is grepping for thread
+  SCM_CRITICAL_SECTION_END were used: they are mentioned here in case
-  problems ;)
+  somebody is grepping for thread problems ;)
 */
 
 static void *

libguile/dynwind.c

@@ -97,14 +97,15 @@ SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
 	    "@end lisp")
 #define FUNC_NAME s_scm_dynamic_wind
 {
-  SCM ans;
+  SCM ans, old_winds;
   SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
 	      out_guard,
 	      SCM_ARG3, FUNC_NAME);
   scm_call_0 (in_guard);
-  scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds);
+  old_winds = scm_i_dynwinds ();
+  scm_i_set_dynwinds (scm_acons (in_guard, out_guard, old_winds));
   ans = scm_call_0 (thunk);
-  scm_dynwinds = SCM_CDR (scm_dynwinds);
+  scm_i_set_dynwinds (old_winds);
   scm_call_0 (out_guard);
   return ans;
 }
@@ -154,20 +155,25 @@ scm_frame_begin (scm_t_frame_flags flags)
   SCM_NEWSMOB (f, tc16_frame, 0);
   if (flags & SCM_F_FRAME_REWINDABLE)
     SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE);
-  scm_dynwinds = scm_cons (f, scm_dynwinds);
+  scm_i_set_dynwinds (scm_cons (f, scm_i_dynwinds ()));
 }
 
 void
 scm_frame_end (void)
 {
+  SCM winds;
+
   /* Unwind upto and including the next frame entry.  We can only
      encounter #<winder> entries on the way.
    */
 
-  while (scm_is_pair (scm_dynwinds))
+  winds = scm_i_dynwinds ();
+  while (scm_is_pair (winds))
     {
-      SCM entry = SCM_CAR (scm_dynwinds);
+      SCM entry = SCM_CAR (winds);
-      scm_dynwinds = SCM_CDR (scm_dynwinds);
+      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);
+      wind = scm_i_dynwinds ();
-      scm_dynwinds = SCM_CDR (scm_dynwinds);
+      wind_elt = SCM_CAR (wind);
+      scm_i_set_dynwinds (SCM_CDR (wind));
 
       if (FRAME_P (wind_elt))
 	{

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_frame_pthread_mutex_lock (&scm_i_misc_mutex);
-                            &scm_i_misc_mutex,
-                            SCM_F_WIND_EXPLICITLY);
-  scm_mutex_lock (&scm_i_misc_mutex);
 
   ret = scm_from_locale_string (SCM_I_STRERROR (scm_to_int (err)));
 

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
+     evaluates EXP while MOD_OR_STATE is the current module or current
-     setting the current module to MOD, invoking scm_primitive_eval on
+     dynamic state (as appropriate).  This is done by setting the
-     EXP, and then restoring the current module to the value it had
+     current module (or dynamic state) to MOD_OR_STATE, invoking
-     previously.  That is, while EXP is evaluated, changes to the
+     scm_primitive_eval on EXP, and then restoring the current module
-     current module are tracked, but these changes do not persist when
+     (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)
+scm_eval_x (SCM exp, SCM module_or_state)
-#define FUNC_NAME "eval!"
 {
-  SCM_VALIDATE_MODULE (2, module);
+  SCM res;
 
-  return scm_internal_dynamic_wind 
+  scm_frame_begin (SCM_F_FRAME_REWINDABLE);
-    (change_environment, inner_eval_x, restore_environment,
+  if (scm_is_dynamic_state (module_or_state))
-     (void *) SCM_UNPACK (exp),
+    scm_frame_current_dynamic_state (module_or_state);
-     (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
+  else
-}
+    scm_frame_current_module (module_or_state);
-#undef FUNC_NAME
 
-static SCM
+  res = scm_primitive_eval_x (exp);
-inner_eval (void *data)
+
-{
+  scm_frame_end ();
-  return scm_primitive_eval (SCM_PACK(data));
+  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"
+            "@var{module_or_state} is made the current module when\n"
-            "is reset to its previous value when @var{eval} returns.\n"
+	    "it is a module, or the current dynamic state when it is\n"
+	    "a dynamic state."
 	    "Example: (eval '(+ 1 2) (interaction-environment))")
 #define FUNC_NAME s_scm_eval
 {
-  SCM_VALIDATE_MODULE (2, module);
+  SCM res;
 
-  return scm_internal_dynamic_wind 
+  scm_frame_begin (SCM_F_FRAME_REWINDABLE);
-    (change_environment, inner_eval, restore_environment,
+  if (scm_is_dynamic_state (module_or_state))
-     (void *) SCM_UNPACK (exp),
+    scm_frame_current_dynamic_state (module_or_state);
-     (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
+  else
+    scm_frame_current_module (module_or_state);
+
+  res = scm_primitive_eval (exp);
+
+  scm_frame_end ();
+  return res;
 }
 #undef FUNC_NAME
 
@@ -6004,7 +5993,7 @@ scm_init_eval ()
 		 SCM_N_EVAL_OPTIONS);
   
   scm_tc16_promise = scm_make_smob_type ("promise", 0);
-  scm_set_smob_mark (scm_tc16_promise, scm_markcdr);
+  scm_set_smob_mark (scm_tc16_promise, promise_mark);
   scm_set_smob_free (scm_tc16_promise, promise_free);
   scm_set_smob_print (scm_tc16_promise, promise_print);
 

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) \
+#define SCM_PROMISE_MUTEX     SCM_SMOB_OBJECT_2
-  ((scm_t_rec_mutex *) SCM_SMOB_DATA_2 (promise))
 #define SCM_PROMISE_DATA      SCM_SMOB_OBJECT
 #define SCM_SET_PROMISE_DATA  SCM_SET_SMOB_OBJECT
 

libguile/filesys.c

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

libguile/fluids.c

@@ -15,7 +15,8 @@
  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  */
 
-
+#include <stdio.h>
+#include <string.h>
 
 #include "libguile/_scm.h"
 #include "libguile/print.h"
@@ -27,84 +28,247 @@
 #include "libguile/ports.h"
 #include "libguile/deprecation.h"
 #include "libguile/lang.h"
-
-#define INITIAL_FLUIDS 10
 #include "libguile/validate.h"
 
-static volatile long n_fluids;
+#define FLUID_GROW 20
-scm_t_bits scm_tc16_fluid;
 
-SCM
+/* A lot of the complexity below stems from the desire to reuse fluid
-scm_i_make_initial_fluids ()
+   slots.  Normally, fluids should be pretty global and long-lived
-{
+   things, so that reusing their slots should not be overly critical,
-  return scm_c_make_vector (INITIAL_FLUIDS, SCM_BOOL_F);
+   but it is the right thing to do nevertheless.  The code therefore
-}
+   puts the burdon on allocating and collection fluids and keeps
+   accessing fluids lock free.  This is achieved by manipulating the
+   global state of the fluid machinery mostly in single threaded
+   sections.
 
+   Reusing a fluid slot means that it must be reset to #f in all
+   dynamic states.  We do this by maintaining a weak list of all
+   dynamic states, which is used after a GC to do the resetting.
+
+   Also, the fluid vectors in the dynamic states need to grow from
+   time to time when more fluids are created.  We do this in a single
+   threaded section so that threads do not need to lock when accessing
+   a fluid in the normal way.
+*/
+
+static scm_i_pthread_mutex_t fluid_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+/* Protected by fluid_admin_mutex, but also accessed during GC.  See
+   next_fluid_num for a discussion of this.
+ */
+static size_t allocated_fluids_len = 0;
+static size_t allocated_fluids_num = 0;
+static char *allocated_fluids = NULL;
+
+static scm_t_bits tc16_fluid;
+
+#define IS_FLUID(x)         SCM_SMOB_PREDICATE(tc16_fluid, (x))
+#define FLUID_NUM(x)        ((size_t)SCM_SMOB_DATA(x))
+#define FLUID_NEXT(x)       SCM_SMOB_OBJECT_2(x)
+#define SET_FLUID_NEXT(x,y) SCM_SET_SMOB_OBJECT_2((x), (y))
+
+static scm_t_bits tc16_dynamic_state;
+
+#define IS_DYNAMIC_STATE(x)        SCM_SMOB_PREDICATE(tc16_dynamic_state, (x))
+#define DYNAMIC_STATE_FLUIDS(x)        SCM_SMOB_OBJECT(x)
+#define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_SMOB_OBJECT((x), (y))
+#define DYNAMIC_STATE_NEXT(x)          SCM_SMOB_OBJECT_2(x)
+#define SET_DYNAMIC_STATE_NEXT(x, y)   SCM_SET_SMOB_OBJECT_2((x), (y))
+
+/* Weak lists of all dynamic states and all fluids.
+ */
+static SCM all_dynamic_states = SCM_EOL;
+static SCM all_fluids = SCM_EOL;
+
+/* Make sure that the dynamic state STATE has the right size.  This
+   must be called while being single threaded and while
+   fluid_admin_mutex is held.
+*/
 static void
-grow_fluids (scm_root_state *root_state, int new_length)
+ensure_state_size (SCM state)
 {
-  SCM old_fluids, new_fluids;
+  SCM fluids = DYNAMIC_STATE_FLUIDS (state);
-  long old_length, i;
+  size_t len = SCM_SIMPLE_VECTOR_LENGTH (fluids), i;
 
-  old_fluids = root_state->fluids;
+  if (len != allocated_fluids_len)
-  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)
     {
-      SCM_SIMPLE_VECTOR_SET (new_fluids, i,
+      SCM new_fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F);
-			     SCM_SIMPLE_VECTOR_REF (old_fluids, i));
+      for (i = 0; i < len; i++)
-      i++;
+	SCM_SIMPLE_VECTOR_SET (new_fluids, i,
+			       SCM_SIMPLE_VECTOR_REF (fluids, i));
+      SET_DYNAMIC_STATE_FLUIDS (state, new_fluids);
     }
-  while (i < new_length)
-    {
-      SCM_SIMPLE_VECTOR_SET (new_fluids, i, SCM_BOOL_F);
-      i++;
-    }
-
-  root_state->fluids = new_fluids;
 }
 
-void
+/* Make sure that all states have the right size.  This must be called
-scm_i_copy_fluids (scm_root_state *root_state)
+   while fluid_admin_mutex is held.
+*/
+static void
+ensure_all_state_sizes ()
 {
-  grow_fluids (root_state, SCM_SIMPLE_VECTOR_LENGTH (root_state->fluids));
+  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 *statep, *fluidp;
+
+  /* Scan all fluids and deallocate the unmarked ones.
+   */
+  fluidp = &all_fluids;
+  while (!scm_is_null (*fluidp))
+    {
+      if (!SCM_GC_MARK_P (*fluidp))
+	{
+	  allocated_fluids_num -= 1;
+	  allocated_fluids[FLUID_NUM (*fluidp)] = 0;
+	  *fluidp = FLUID_NEXT (*fluidp);
+	}
+      else
+	fluidp = &FLUID_NEXT (*fluidp);
+    }
+
+  /* Scan all dynamic states and remove the unmarked ones.  The live
+     ones are updated for unallocated fluids.
+  */
+  statep = &all_dynamic_states;
+  while (!scm_is_null (*statep))
+    {
+      if (!SCM_GC_MARK_P (*statep))
+	*statep = DYNAMIC_STATE_NEXT (*statep);
+      else
+	{
+	  SCM fluids = DYNAMIC_STATE_FLUIDS (*statep);
+	  size_t len, i;
+	  
+	  len = SCM_SIMPLE_VECTOR_LENGTH (fluids);
+	  for (i = 0; i < len && i < allocated_fluids_len; i++)
+	    if (allocated_fluids[i] == 0)
+	      SCM_SIMPLE_VECTOR_SET (fluids, i, SCM_BOOL_F);
+
+	  statep = &DYNAMIC_STATE_NEXT (*statep);
+	}
+    }
+
+  return NULL;
+}
+
+static size_t
+fluid_free (SCM fluid)
+{
+  /* The real work is done in scan_dynamic_states_and_fluids.  We can
+     not touch allocated_fluids etc here since a smob free routine can
+     be run at any time, in any thread.
+  */
+  return 0;
 }
 
 static int
 fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 {
   scm_puts ("#<fluid ", port);
-  scm_intprint ((int) SCM_FLUID_NUM (exp), 10, port);
+  scm_intprint ((int) FLUID_NUM (exp), 10, port);
   scm_putc ('>', port);
   return 1;
 }
 
-static long
+static size_t
 next_fluid_num ()
 {
-  long n;
+  size_t n;
-  SCM_CRITICAL_SECTION_START;
+
-  n = n_fluids++;
+  scm_frame_begin (0);
-  SCM_CRITICAL_SECTION_END;
+  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"
+	    "Fluids are objects that can hold one\n"
-	    "value per dynamic root.  That is, modifications to this value are\n"
+	    "value per dynamic state.  That is, modifications to this value are\n"
-	    "only visible to code that executes within the same dynamic root as\n"
+	    "only visible to code that executes with the same dynamic state as\n"
-	    "the modifying code.  When a new dynamic root is constructed, it\n"
+	    "the modifying code.  When a new dynamic state is constructed, it\n"
-	    "inherits the values from its parent.  Because each thread executes\n"
+	    "inherits the values from its parent.  Because each thread normally executes\n"
-	    "in its own dynamic root, you can use fluids for thread local storage.")
+	    "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_NEWSMOB2 (fluid, tc16_fluid,
-  SCM_RETURN_NEWSMOB (scm_tc16_fluid, n);
+		(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);
+  return SCM_SIMPLE_VECTOR_REF (fluids, 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);
 }
 #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);
+  SCM_SIMPLE_VECTOR_SET (fluids, FLUID_NUM (fluid), value);
-
-  if (SCM_SIMPLE_VECTOR_LENGTH (scm_root->fluids) <= n)
-    grow_fluids (scm_root, n+1);
-  SCM_SIMPLE_VECTOR_SET (scm_root->fluids, n, 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"
 }
 

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
+   value per dynamic state.  That is, modifications to this value are
-   only visible to code that executes within the same dynamic root as
+   only visible to code that executes with the same dynamic state as
-   the modifying code.  When a new dynamic root is constructed, it
+   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
+   to index a vector that holds the values of all fluids.  A dynamic
-   has its own vector.
+   state consists of this vector, wrapped in a smob so that the vector
-
+   can grow.
-   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))
 
 /* 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
+   do no error checking at all.  The first argument is the index
-that the relevant fluid already exists in the current dynamic root.
+   number of the fluid, obtained via SCM_FLUID_NUM, not the fluid
-The easiest way to ensure this is to execute a SCM_FLUID_SET_X in the
+   itself.  You must make sure that the fluid remains protected as
-topmost root, for example right after SCM_MAKE_FLUID in your
+   long you use its number since numbers of unused fluids are reused
-SCM_INIT_MUMBLE routine that gets called from SCM_BOOT_GUILE_1.  The
+   eventually.
-first argument is the index number of the fluid, obtained via
+*/
-SCM_FLUID_NUM, not the fluid itself. */
 
-#define SCM_FAST_FLUID_REF(n) (SCM_VELTS(scm_root->fluids)[n])
+#define SCM_FLUID_NUM(x)             scm_i_fluid_num (x)
-#define SCM_FAST_FLUID_SET_X(n, val) (SCM_VELTS(scm_root->fluids)[n] = val)
+#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 SCM scm_make_dynamic_state (SCM parent);
-SCM_API void scm_i_copy_fluids (scm_root_state *);
+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 */

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

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_i_pthread_mutex_destroy (&future->mutex);
-  scm_cond_destroy (&future->cond);
+  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_i_pthread_mutex_init (&f->mutex, NULL);
-  scm_cond_init (&f->cond, 0);
+  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_i_pthread_cond_signal (SCM_FUTURE_COND (future));
-  scm_mutex_unlock (SCM_FUTURE_MUTEX (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_i_pthread_cond_signal (SCM_FUTURE_COND (next));
-	  scm_mutex_unlock (SCM_FUTURE_MUTEX (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 ()
 {

libguile/futures.h

@@ -29,8 +29,8 @@
 
 typedef struct scm_t_future {
   SCM data;
-  scm_t_mutex mutex;
+  scm_i_pthread_mutex_t mutex;
-  scm_t_cond cond;
+  scm_i_pthread_cond_t cond;
   int status;
   int die_p;
 } scm_t_future;

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,

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

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 cell = scm_cons (obj, SCM_EOL);
-  scm_permobjs = scm_cons (obj, scm_permobjs);
+  SCM_CRITICAL_SECTION_START;
-  SCM_REALLOW_INTS;
+  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);

libguile/gc.h

@@ -25,12 +25,7 @@
 #include "libguile/__scm.h"
 
 #include "libguile/hooks.h"
-
+#include "libguile/threads.h"
-#if SCM_USE_PTHREAD_THREADS
-# include "libguile/pthread-threads.h"
-#else
-# include "libguile/null-threads.h"
-#endif
 
 
 
@@ -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)		\
+#define SCM_SET_FREELIST_LOC(key,ptr) scm_i_pthread_setspecific ((key), (ptr))
-  do { SCM *ls = (SCM *) malloc (sizeof (SCM));	\
+#define SCM_FREELIST_LOC(key) ((SCM *) scm_i_pthread_getspecific (key))
-       *ls = SCM_EOL; 				\
+SCM_API scm_i_pthread_key_t scm_i_freelist;
-       scm_setspecific ((key), ls); } while (0)
+SCM_API scm_i_pthread_key_t scm_i_freelist2;
-#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;
 SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist;
 SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2;
 

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_defer_ints() SCM_CRITICAL_SECTION_START
-#define gh_allow_ints() SCM_ALLOW_INTS
+#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, 

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

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);
+                port);
-      scm_newline (scm_cur_errp);
+      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_display (SCM_CAR (pair), port);
-          scm_newline (scm_cur_errp);
+          scm_newline (port);
         }
 
       self_centered_zombies = SCM_EOL;

libguile/init.c

@@ -133,46 +133,6 @@
 #include <unistd.h>
 #endif
 
-/* Setting up the stack.  */
-
-static void
-restart_stack (void *base)
-{
-  scm_dynwinds = SCM_EOL;
-  SCM_DYNENV (scm_rootcont) = SCM_EOL;
-  SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
-  SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
-  SCM_BASE (scm_rootcont) = base;
-}
-
-static void
-start_stack (void *base)
-{
-  SCM root;
-
-  root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
-  scm_set_root (SCM_ROOT_STATE (root));
-  scm_stack_base = base;
-
-  scm_exitval = SCM_BOOL_F;	/* vestigial */
-
-  scm_root->fluids = scm_i_make_initial_fluids ();
-
-  /* Create an object to hold the root continuation.
-   */
-  {
-    scm_t_contregs *contregs = scm_gc_malloc (sizeof (scm_t_contregs),
-					      "continuation");
-    contregs->num_stack_items = 0;
-    contregs->seq = 0;
-    SCM_NEWSMOB (scm_rootcont, scm_tc16_continuation, contregs);
-  }
-
-  /* The remainder of stack initialization is factored out to another
-   * function so that if this stack is ever exitted, it can be
-   * re-entered using restart_stack.  */
-  restart_stack (base);
-}
 
 
 #if 0
@@ -283,18 +243,18 @@ scm_init_standard_ports ()
      buffered input on stdin can reset \ex{(current-input-port)} to
      block buffering for higher performance.  */
 
-  scm_cur_inp
+  scm_set_current_input_port 
-    = scm_standard_stream_to_port (0, 
+    (scm_standard_stream_to_port (0, 
-				   isatty (0) ? "r0" : "r",
+				  isatty (0) ? "r0" : "r",
-				   "standard input");
+				  "standard input"));
-  scm_cur_outp = scm_standard_stream_to_port (1,
+  scm_set_current_output_port
-					      isatty (1) ? "w0" : "w",
+    (scm_standard_stream_to_port (1,
-					      "standard output");
+				  isatty (1) ? "w0" : "w",
-  scm_cur_errp = scm_standard_stream_to_port (2,
+				  "standard output"));
-					      isatty (2) ? "w0" : "w",
+  scm_set_current_error_port
-					      "standard error");
+    (scm_standard_stream_to_port (2,
-
+				  isatty (2) ? "w0" : "w",
-  scm_cur_loadp = SCM_BOOL_F;
+				  "standard error"));
 }
 
 
@@ -345,11 +305,7 @@ struct main_func_closure
   char **argv;			/* the argument list it should receive */
 };
 
-
+static void *invoke_main_func(void *body_data);
-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);
 
 
 /* Fire up the Guile Scheme interpreter.
@@ -383,10 +339,6 @@ static SCM invoke_main_func(void *body_data);
 void
 scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
 {
-  /* The garbage collector uses the address of this variable as one
-     end of the stack, and the address of one of its own local
-     variables as the other end.  */
-  SCM_STACKITEM dummy;
   struct main_func_closure c;
 
   c.main_func = main_func;
@@ -394,19 +346,55 @@ scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
   c.argc = argc;
   c.argv = argv;
 
-  scm_boot_guile_1 (&dummy, &c);
+  scm_with_guile (invoke_main_func, &c);
+}
+
+static void *
+invoke_main_func (void *body_data)
+{
+  struct main_func_closure *closure = (struct main_func_closure *) body_data;
+
+  scm_set_program_arguments (closure->argc, closure->argv, 0);
+  (*closure->main_func) (closure->closure, closure->argc, closure->argv);
+
+  scm_restore_signals ();
+
+  /* This tick gives any pending
+   * asyncs a chance to run.  This must be done after
+   * the call to scm_restore_signals.
+   */
+  SCM_ASYNC_TICK;
+
+  /* If the caller doesn't want this, they should exit from main_func
+     themselves.
+  */
+  exit (0);
+
+  /* never reached */
+  return NULL;
+}
+
+scm_i_pthread_mutex_t scm_i_init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+int scm_initialized_p = 0;
+
+static void *
+really_cleanup_for_exit (void *unused)
+{
+  scm_flush_all_ports ();
+  return NULL;
+}
+
+static void
+cleanup_for_exit ()
+{
+  /* This function might be called in non-guile mode, so we need to
+     enter it temporarily. 
+  */
+  scm_with_guile (really_cleanup_for_exit, NULL);
 }
 
 void
-scm_init_guile ()
+scm_i_init_guile (SCM_STACKITEM *base)
-{
-  scm_init_guile_1 ((SCM_STACKITEM *)scm_get_stack_base ());
-}
-
-int scm_initialized_p = 0;
-
-static void
-scm_init_guile_1 (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);
+  scm_init_threads ();            /* requires fluids */
-  start_stack (base);
   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"

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

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    

libguile/iselect.h

@@ -52,21 +52,11 @@
 
 #endif /* no FD_SET */
 
-SCM_API int scm_internal_select (int fds,
+SCM_API int scm_std_select (int fds,
-				 SELECT_TYPE *rfds,
+			    SELECT_TYPE *rfds,
-				 SELECT_TYPE *wfds,
+			    SELECT_TYPE *wfds,
-				 SELECT_TYPE *efds,
+			    SELECT_TYPE *efds,
-				 struct timeval *timeout);
+			    struct timeval *timeout);
-
-#if SCM_USE_COOP_THREADS
-
-SCM_API int scm_I_am_dead;
-
-SCM_API void scm_error_revive_threads (void);
-
-#endif /* SCM_USE_COOP_THREADS */
-
-SCM_API void scm_init_iselect (void);
 
 #endif  /* SCM_ISELECT_H */
 

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

libguile/null-threads.c

@@ -15,318 +15,51 @@
  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  */
 
+#include <stdlib.h>
+#include "libguile/_scm.h"
 
-
+#if SCM_USE_NULL_THREADS
 
-#include "libguile/validate.h"
+#include "libguile/null-threads.h"
-#include "libguile/root.h"
-#include "libguile/stackchk.h"
-#include "libguile/async.h"
-#include <sys/time.h>
-#include <sys/types.h>
-#include <time.h>
-#include <stdio.h>
 
-void *scm_null_threads_data;
+static scm_i_pthread_key_t *all_keys = NULL;
 
-static SCM main_thread;
+static void
-
+destroy_keys (void)
-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_i_pthread_key_t *key;
-  scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_null_mutex));
+  int again;
-  scm_tc16_condvar = scm_make_smob_type ("condition-variable",
-					 sizeof (scm_null_cond));
 
-  main_thread = scm_permanent_object (scm_cell (scm_tc16_thread, 0));
+  do {
-  scm_null_threads_data = NULL;
+    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);
 }
 
-#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)
+scm_i_pthread_key_create (scm_i_pthread_key_t *key,
-#define FUNC_NAME s_scm_thread_exited_p
+			  void (*destr_func) (void *))
 {
+  if (all_keys == NULL)
+    atexit (destroy_keys);
+
+  key->next = all_keys;
+  all_keys = key;
+  key->value = NULL;
+  key->destr_func = destr_func;
+
   return 0;
 }
-#undef FUNC_NAME
 
-SCM
+#endif /* SCM_USE_NULL_THREADS */
-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:

libguile/null-threads.h

@@ -3,7 +3,7 @@
 #ifndef SCM_NULL_THREADS_H
 #define SCM_NULL_THREADS_H
 
-/* Copyright (C) 2002 Free Software Foundation, Inc.
+/* Copyright (C) 2005 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -22,101 +22,81 @@
 
 
 
-/* The null-threads implementation.  We provide the standard API, but
+/* The null-threads implementation.  We provide the subset of the
-   no new threads can be created.
+   standard pthread API that is used by Guile, but no new threads can
+   be created.
+
+   This file merely exits so that Guile can be compiled and run
+   without using pthreads.  Improving performance via optimizations
+   that are possible in a single-threaded program is not a primary
+   goal.
 */
 
-#error temporarily broken, compile with threads enabled (default option)
+#include <errno.h>
 
-/* We can't switch so don't bother trying. 
+/* Threads 
 */
-#undef  SCM_THREAD_SWITCHING_CODE
+#define scm_i_pthread_t                     int
-#define SCM_THREAD_SWITCHING_CODE
+#define scm_i_pthread_self()                0
+#define scm_i_pthread_create(t,a,f,d)       (*(t)=0, (void)(f), ENOSYS)
+#define scm_i_pthread_detach(t)             do { } while (0)
+#define scm_i_pthread_exit(v)               exit(0)
+#define scm_i_sched_yield()                 0
 
-#define scm_t_thread int
+/* Signals
+ */
+#define scm_i_pthread_sigmask               sigprocmask
 
-/* The "(void)(...)" constructs in the expansions are there to ensure
+/* Mutexes
-   that the side effects of the argument expressions take place.
+ */
-*/
+#define SCM_I_PTHREAD_MUTEX_INITIALIZER     0
+#define SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER     0
+#define scm_i_pthread_mutex_t               int
+#define scm_i_pthread_mutex_init(m,a)       (*(m) = 0)
+#define scm_i_pthread_mutex_destroy(m)      do { (void)(m); } while(0)
+#define scm_i_pthread_mutex_trylock(m)      ((*(m))++)
+#define scm_i_pthread_mutex_lock(m)         ((*(m))++)
+#define scm_i_pthread_mutex_unlock(m)       ((*(m))--)
 
-#define scm_thread_create(th,proc,data) ((void)(proc), (void)(data), ENOTSUP)
+/* Condition variables
-#define scm_thread_join(th)             do { (void)(th); abort(); } while(0)
+ */
-#define scm_thread_detach(th)           do { (void)(th); abort(); } while(0)
+#define SCM_I_PTHREAD_COND_INITIALIZER      0
-#define scm_thread_self()               0
+#define scm_i_pthread_cond_t                int
+#define scm_i_pthread_cond_init(c,a)        (*(c) = 0)
+#define scm_i_pthread_cond_destroy(c)       do { (void)(c); } while(0)
+#define scm_i_pthread_cond_signal(c)        (*(c) = 1)
+#define scm_i_pthread_cond_broadcast(c)     (*(c) = 1)
+#define scm_i_pthread_cond_wait(c,m)        (abort(), 0)
+#define scm_i_pthread_cond_timedwait(c,m,t) (abort(), 0)
 
-#define scm_t_mutex int
+/* Onces
+ */
+#define scm_i_pthread_once_t                int
+#define SCM_I_PTHREAD_ONCE_INIT             0
+#define scm_i_pthread_once(o,f)             do { \
+                                              if(!*(o)) { *(o)=1; f (); } \
+                                            } while(0)
 
-#define scm_mutex_init(mx)              do { (void)(mx); } while(0)
+/* Thread specific storage
-#define scm_mutex_destroy(mx)           do { (void)(mx); } while(0)
+ */
-#define scm_mutex_lock(mx)              do { (void)(mx); } while(0)
+typedef struct scm_i_pthread_key_t {
-#define scm_mutex_trylock(mx)           ((void)(mx), 1)
+  struct scm_i_pthread_key_t *next;
-#define scm_mutex_unlock(mx)            do { (void)(mx); } while(0)
+  void *value;
+  void (*destr_func) (void *);
+} scm_i_pthread_key_t;
 
-#define scm_t_cond int
+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)
 
-#define scm_cond_init(cv)               do { (void)(cv); } while(0)
+/* Convenience functions
-#define scm_cond_destroy(cv)            do { (void)(cv); } while(0)
+ */
-#define scm_cond_wait(cv,mx)            ((void)(cv), (void)(mx), ENOTSUP)
+#define scm_i_scm_pthread_mutex_lock        scm_i_pthread_mutex_lock
-#define scm_cond_timedwait(cv,mx,at)    ((void)(cv), (void)(mx), (void)(at), \
+#define scm_i_frame_pthread_mutex_lock      scm_i_pthread_mutex_lock
-                                         ENOTSUP)
+#define scm_i_scm_pthread_cond_wait         scm_i_pthread_cond_wait
-#define scm_cond_signal(cv)             do { (void)(cv); } while(0)
+#define scm_i_scm_pthread_cond_timedwait    scm_i_pthread_cond_timedwait
-#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 */
 

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

libguile/ports.c

@@ -41,6 +41,7 @@
 #include "libguile/validate.h"
 #include "libguile/ports.h"
 #include "libguile/vectors.h"
+#include "libguile/fluids.h"
 
 #ifdef HAVE_STRING_H
 #include <string.h>
@@ -121,7 +122,7 @@ scm_make_port_type (char *name,
   char *tmp;
   if (255 <= scm_numptob)
     goto ptoberr;
-  SCM_DEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
   SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs,
 				       (1 + scm_numptob)
 				       * sizeof (scm_t_ptob_descriptor)));
@@ -148,7 +149,7 @@ scm_make_port_type (char *name,
 
       scm_numptob++;
     }
-  SCM_ALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
   if (!tmp)
     {
     ptoberr:
@@ -246,7 +247,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0,
   scm_t_port *pt;
 
   if (SCM_UNBNDP (port))
-    port = scm_cur_inp;
+    port = scm_current_input_port ();
   else
     SCM_VALIDATE_OPINPORT (1, port);
 
@@ -341,6 +342,11 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
 
 /* Standard ports --- current input, output, error, and more(!).  */
 
+static SCM cur_inport_fluid;
+static SCM cur_outport_fluid;
+static SCM cur_errport_fluid;
+static SCM cur_loadport_fluid;
+
 SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
 	    (),
 	    "Return the current input port.  This is the default port used\n"
@@ -348,7 +354,7 @@ SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
 	    "returns the @dfn{standard input} in Unix and C terminology.")
 #define FUNC_NAME s_scm_current_input_port
 {
-  return scm_cur_inp;
+  return scm_fluid_ref (cur_inport_fluid);
 }
 #undef FUNC_NAME
 
@@ -360,7 +366,7 @@ SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
 	    "Unix and C terminology.")
 #define FUNC_NAME s_scm_current_output_port
 {
-  return scm_cur_outp;
+  return scm_fluid_ref (cur_outport_fluid);
 }
 #undef FUNC_NAME
 
@@ -370,7 +376,7 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
 	    "@dfn{standard error} in Unix and C terminology).")
 #define FUNC_NAME s_scm_current_error_port
 {
-  return scm_cur_errp;
+  return scm_fluid_ref (cur_errport_fluid);
 }
 #undef FUNC_NAME
 
@@ -380,7 +386,7 @@ SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
             "The load port is used internally by @code{primitive-load}.")
 #define FUNC_NAME s_scm_current_load_port
 {
-  return scm_cur_loadp;
+  return scm_fluid_ref (cur_loadport_fluid);
 }
 #undef FUNC_NAME
 
@@ -393,9 +399,9 @@ SCM_DEFINE (scm_set_current_input_port, "set-current-input-port", 1, 0, 0,
 	    "so that they use the supplied @var{port} for input or output.")
 #define FUNC_NAME s_scm_set_current_input_port
 {
-  SCM oinp = scm_cur_inp;
+  SCM oinp = scm_fluid_ref (cur_inport_fluid);
   SCM_VALIDATE_OPINPORT (1, port);
-  scm_cur_inp = port;
+  scm_fluid_set_x (cur_inport_fluid, port);
   return oinp;
 }
 #undef FUNC_NAME
@@ -406,10 +412,10 @@ SCM_DEFINE (scm_set_current_output_port, "set-current-output-port", 1, 0, 0,
 	    "Set the current default output port to @var{port}.")
 #define FUNC_NAME s_scm_set_current_output_port
 {
-  SCM ooutp = scm_cur_outp;
+  SCM ooutp = scm_fluid_ref (cur_outport_fluid);
   port = SCM_COERCE_OUTPORT (port);
   SCM_VALIDATE_OPOUTPORT (1, port);
-  scm_cur_outp = port;
+  scm_fluid_set_x (cur_outport_fluid, port);
   return ooutp;
 }
 #undef FUNC_NAME
@@ -420,69 +426,47 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
 	    "Set the current default error port to @var{port}.")
 #define FUNC_NAME s_scm_set_current_error_port
 {
-  SCM oerrp = scm_cur_errp;
+  SCM oerrp = scm_fluid_ref (cur_errport_fluid);
   port = SCM_COERCE_OUTPORT (port);
   SCM_VALIDATE_OPOUTPORT (1, port);
-  scm_cur_errp = port;
+  scm_fluid_set_x (cur_errport_fluid, port);
   return oerrp;
 }
 #undef FUNC_NAME
 
-typedef struct {
-  SCM value;
-  SCM (*getter) (void);
-  SCM (*setter) (SCM);
-} swap_data;
-
-static void
-swap_port (SCM scm_data)
-{
-  swap_data *d = (swap_data *)SCM_MALLOCDATA (scm_data);
-  SCM t;
-
-  t = d->getter ();
-  d->setter (d->value);
-  d->value = t;
-}
-
-static void
-scm_frame_current_foo_port (SCM port,
-			   SCM (*getter) (void), SCM (*setter) (SCM))
-{
-  SCM scm_data = scm_malloc_obj (sizeof (swap_data));
-  swap_data *data = (swap_data *)SCM_MALLOCDATA (scm_data);
-  data->value = port;
-  data->getter = getter;
-  data->setter = setter;
-  
-  scm_frame_rewind_handler_with_scm (swap_port, scm_data,
-				     SCM_F_WIND_EXPLICITLY);
-  scm_frame_unwind_handler_with_scm (swap_port, scm_data,
-				     SCM_F_WIND_EXPLICITLY);
-}
-
 void
 scm_frame_current_input_port (SCM port)
+#define FUNC_NAME NULL
 {
-  scm_frame_current_foo_port (port,
+  SCM_VALIDATE_OPINPORT (1, port);
-			      scm_current_input_port,
+  scm_frame_fluid (cur_inport_fluid, port);
-			      scm_set_current_input_port);
 }
+#undef FUNC_NAME
 
 void
 scm_frame_current_output_port (SCM port)
+#define FUNC_NAME NULL
 {
-  scm_frame_current_foo_port (port,
+  port = SCM_COERCE_OUTPORT (port);
-			      scm_current_output_port,
+  SCM_VALIDATE_OPOUTPORT (1, port);
-			      scm_set_current_output_port);
+  scm_frame_fluid (cur_outport_fluid, port);
 }
+#undef FUNC_NAME
 
 void
 scm_frame_current_error_port (SCM port)
+#define FUNC_NAME NULL
 {
-  scm_frame_current_foo_port (port,
+  port = SCM_COERCE_OUTPORT (port);
-			      scm_current_error_port,
+  SCM_VALIDATE_OPOUTPORT (1, port);
-			      scm_set_current_error_port);
+  scm_frame_fluid (cur_errport_fluid, port);
+}
+#undef FUNC_NAME
+
+void
+scm_i_frame_current_load_port (SCM port)
+{
+  scm_frame_fluid (cur_loadport_fluid, port);
 }
 
 
@@ -493,7 +477,7 @@ scm_t_port **scm_i_port_table;
 long scm_i_port_table_size = 0;	/* Number of ports in scm_i_port_table.  */
 long scm_i_port_table_room = 20;	/* Size of the array.  */
 
-SCM_GLOBAL_MUTEX (scm_i_port_table_mutex);
+scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
 /* This function is not and should not be thread safe. */
 
@@ -764,9 +748,9 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
     rv = (scm_ptobs[i].close) (port);
   else
     rv = 0;
-  scm_mutex_lock (&scm_i_port_table_mutex);
+  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
   scm_remove_from_port_table (port);
-  scm_mutex_unlock (&scm_i_port_table_mutex);
+  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
   SCM_CLR_PORT_OPEN_FLAG (port);
   return scm_from_bool (rv >= 0);
 }
@@ -815,18 +799,18 @@ scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
      can change arbitrarily (from a GC, for example).  So we first
      collect the ports into a vector. -mvo */
 
-  scm_mutex_lock (&scm_i_port_table_mutex);
+  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
   n = scm_i_port_table_size;
-  scm_mutex_unlock (&scm_i_port_table_mutex);
+  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
 
   ports = scm_c_make_vector (n, SCM_BOOL_F);
 
-  scm_mutex_lock (&scm_i_port_table_mutex);
+  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
   if (n > scm_i_port_table_size)
     n = scm_i_port_table_size;
   for (i = 0; i < n; i++)
     SCM_SIMPLE_VECTOR_SET (ports, i, scm_i_port_table[i]->port);
-  scm_mutex_unlock (&scm_i_port_table_mutex);
+  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
 
   for (i = 0; i < n; i++)
     proc (data, SCM_SIMPLE_VECTOR_REF (ports, i));
@@ -919,7 +903,7 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
 #define FUNC_NAME s_scm_force_output
 {
   if (SCM_UNBNDP (port))
-    port = scm_cur_outp;
+    port = scm_current_output_port ();
   else
     {
       port = SCM_COERCE_OUTPORT (port);
@@ -938,13 +922,13 @@ SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
 {
   size_t i;
 
-  scm_mutex_lock (&scm_i_port_table_mutex);
+  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
   for (i = 0; i < scm_i_port_table_size; i++)
     {
       if (SCM_OPOUTPORTP (scm_i_port_table[i]->port))
 	scm_flush (scm_i_port_table[i]->port);
     }
-  scm_mutex_unlock (&scm_i_port_table_mutex);
+  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -958,7 +942,7 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
 {
   int c;
   if (SCM_UNBNDP (port))
-    port = scm_cur_inp;
+    port = scm_current_input_port ();
   SCM_VALIDATE_OPINPORT (1, port);
   c = scm_getc (port);
   if (EOF == c)
@@ -1300,7 +1284,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
 {
   int c, column;
   if (SCM_UNBNDP (port))
-    port = scm_cur_inp;
+    port = scm_current_input_port ();
   else
     SCM_VALIDATE_OPINPORT (1, port);
   column = SCM_COL(port);
@@ -1325,7 +1309,7 @@ SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0,
 
   SCM_VALIDATE_CHAR (1, cobj);
   if (SCM_UNBNDP (port))
-    port = scm_cur_inp;
+    port = scm_current_input_port ();
   else
     SCM_VALIDATE_OPINPORT (2, port);
 
@@ -1346,7 +1330,7 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0,
 {
   SCM_VALIDATE_STRING (1, str);
   if (SCM_UNBNDP (port))
-    port = scm_cur_inp;
+    port = scm_current_input_port ();
   else
     SCM_VALIDATE_OPINPORT (2, port);
 
@@ -1638,7 +1622,7 @@ write_void_port (SCM port SCM_UNUSED,
 static SCM
 scm_i_void_port (long mode_bits)
 {
-  scm_mutex_lock (&scm_i_port_table_mutex);
+  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
   {
     SCM answer = scm_new_port_table_entry (scm_tc16_void_port);
     scm_t_port * pt = SCM_PTAB_ENTRY(answer);
@@ -1647,7 +1631,7 @@ scm_i_void_port (long mode_bits)
   
     SCM_SETSTREAM (answer, 0);
     SCM_SET_CELL_TYPE (answer, scm_tc16_void_port | mode_bits);
-    scm_mutex_unlock (&scm_i_port_table_mutex);
+    scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
     return answer;
   }
 }
@@ -1683,6 +1667,12 @@ scm_init_ports ()
 
   scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port, 
 					   write_void_port);
+
+  cur_inport_fluid = scm_permanent_object (scm_make_fluid ());
+  cur_outport_fluid = scm_permanent_object (scm_make_fluid ());
+  cur_errport_fluid = scm_permanent_object (scm_make_fluid ());
+  cur_loadport_fluid = scm_permanent_object (scm_make_fluid ());
+
 #include "libguile/ports.x"
 }
 

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

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_frame_pthread_mutex_lock (&scm_i_misc_mutex);
-                            &scm_i_misc_mutex,
-                            SCM_F_WIND_EXPLICITLY);
-  scm_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));
 

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

libguile/pthread-threads.h

@@ -1,9 +1,9 @@
 /* classes: h_files */
 
-#ifndef SCM_THREADS_PTHREADS_H
+#ifndef SCM_PTHREADS_THREADS_H
-#define SCM_THREADS_PTHREADS_H
+#define SCM_PTHREADS_THREADS_H
 
-/* Copyright (C) 2002 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2005 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -25,58 +25,66 @@
 /* The pthreads-threads implementation.  This is a direct mapping.
 */
 
-/* This is an interface between Guile and the pthreads thread package. */
-
 #include <pthread.h>
 #include <sched.h>
 
-#include "libguile/threads-plugin.h"
+/* 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
 
-/* MDJ 021209 <djurfeldt@nada.kth.se>:
+/* Signals
-   The separation of the plugin interface and the low-level C API
-   (currently in threads.h) needs to be completed in a sensible way.
  */
+#define scm_i_pthread_sigmask               pthread_sigmask
 
-/* The scm_t_ types are temporarily used both in plugin and low-level API */
+/* Mutexes
-#define scm_t_thread			pthread_t
+ */
+#define SCM_I_PTHREAD_MUTEX_INITIALIZER     PTHREAD_MUTEX_INITIALIZER
+#define SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER \
+                                       PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP
+#define scm_i_pthread_mutex_t               pthread_mutex_t
+#define scm_i_pthread_mutex_init            pthread_mutex_init
+#define scm_i_pthread_mutex_destroy         pthread_mutex_destroy
+#define scm_i_pthread_mutex_trylock         pthread_mutex_trylock
+#define scm_i_pthread_mutex_lock            pthread_mutex_lock
+#define scm_i_pthread_mutex_unlock          pthread_mutex_unlock
 
-#define scm_i_plugin_thread_create	pthread_create
+/* 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
 
-#define scm_i_plugin_thread_join	pthread_join 
+/* Onces
-#define scm_i_plugin_thread_detach	pthread_detach 
+ */
-#define scm_i_plugin_thread_self	pthread_self
+#define scm_i_pthread_once_t                pthread_once_t
-#define scm_i_plugin_thread_yield	sched_yield
+#define SCM_I_PTHREAD_ONCE_INIT             PTHREAD_ONCE_INIT
+#define scm_i_pthread_once                  pthread_once
 
-extern scm_t_mutexattr scm_i_plugin_mutex; /* The "fast" mutex. */
+/* 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
 
-#define scm_i_plugin_mutex_destroy(m) \
+/* Convenience functions
-  pthread_mutex_destroy ((pthread_mutex_t *) (m))
+ */
-#define scm_i_plugin_mutex_trylock(m) \
+#define scm_i_scm_pthread_mutex_lock        scm_pthread_mutex_lock
-  pthread_mutex_trylock ((pthread_mutex_t *) (m))
+#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
 
-extern scm_t_mutexattr scm_i_plugin_rec_mutex;
+#endif  /* SCM_PTHREADS_THREADS_H */
-
-#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:

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

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

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,

libguile/root.c

@@ -19,6 +19,8 @@
 
 
 #include <string.h>
+#include <stdio.h>
+
 #include "libguile/_scm.h"
 #include "libguile/stackchk.h"
 #include "libguile/dynwind.h"
@@ -34,89 +36,8 @@
 
 SCM scm_sys_protects[SCM_NUM_PROTECTS];
 
-scm_t_bits scm_tc16_root;
-
 
 
-static SCM
-root_mark (SCM root)
-{
-  scm_root_state *s = SCM_ROOT_STATE (root);
-
-  scm_gc_mark (s->rootcont);
-  scm_gc_mark (s->dynwinds);
-  scm_gc_mark (s->progargs);
-  scm_gc_mark (s->exitval);
-  scm_gc_mark (s->cur_inp);
-  scm_gc_mark (s->cur_outp);
-  scm_gc_mark (s->cur_errp);
-  /* No need to gc mark def_loadp */
-  scm_gc_mark (s->fluids);
-  scm_gc_mark (s->active_asyncs);
-  scm_gc_mark (s->signal_asyncs);
-  return SCM_ROOT_STATE (root) -> parent;
-}
-
-
-static int
-root_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
-  scm_puts ("#<root ", port);
-  scm_uintprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
-  scm_putc('>', port);
-  return 1;
-}
-
-
-
-
-SCM
-scm_make_root (SCM parent)
-{
-  SCM root;
-  scm_root_state *root_state;
-
-  root_state = (scm_root_state *) scm_gc_malloc (sizeof (scm_root_state),
-						 "root state");
-  if (SCM_ROOTP (parent))
-    {
-      memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
-      root_state->parent = parent;
-    }
-  else
-    {
-      root_state->parent = SCM_BOOL_F;
-
-      /* Initialize everything right now, in case a GC happens early.  */
-      root_state->rootcont
-	= root_state->dynwinds
-	= root_state->progargs
-	= root_state->exitval
-	= root_state->cur_inp
-	= root_state->cur_outp
-	= root_state->cur_errp
-	= root_state->cur_loadp
-	= root_state->fluids
-	= root_state->handle
-	= root_state->parent
-	= SCM_BOOL_F;
-    }
-  
-  root_state->active_asyncs = SCM_EOL;
-  root_state->signal_asyncs = SCM_EOL;
-  root_state->block_asyncs = 0;
-  root_state->pending_asyncs = 1;
-
-  SCM_NEWSMOB (root, scm_tc16_root, root_state);
-  root_state->handle = root;
-  
-  if (SCM_ROOTP (parent))
-    /* Must be done here so that fluids are GC protected */
-    scm_i_copy_fluids (root_state);
-  
-  return root;
-}
-
 /* {call-with-dynamic-root}
  *
  * Suspending the current thread to evaluate a thunk on the
@@ -125,25 +46,6 @@ scm_make_root (SCM parent)
  * Calls to call-with-dynamic-root return exactly once (unless
  * the process is somehow exitted).  */
 
-/* Some questions about cwdr:
-
-   Couldn't the body just be a closure?  Do we really need to pass
-   args through to it?
-
-   The semantics are a lot like catch's; in fact, we call
-   scm_internal_catch to take care of that part of things.  Wouldn't
-   it be cleaner to say that uncaught throws just disappear into the
-   ether (or print a message to stderr), and let the caller use catch
-   themselves if they want to?
-
-   -JimB */
-
-#if 0
-SCM scm_exitval;		/* INUM with return value */
-#endif
-static long n_dynamic_roots = 0;
-
-
 /* cwdr fills out both of these structures, and then passes a pointer
    to them through scm_internal_catch to the cwdr_body and
    cwdr_handler functions, to tell them how to behave and to get
@@ -201,62 +103,31 @@ cwdr_handler (void *data, SCM tag, SCM args)
   return SCM_UNSPECIFIED;
 }
 
-/* This is the basic code for new root creation.
- *
- * WARNING!  The order of actions in this routine is in many ways
- * critical.  E. g., it is essential that an error doesn't leave Guile
- * in a messed up state.  */
-
 SCM 
 scm_internal_cwdr (scm_t_catch_body body, void *body_data,
 		   scm_t_catch_handler handler, void *handler_data,
 		   SCM_STACKITEM *stack_start)
 {
-  SCM old_rootcont, old_winds;
   struct cwdr_handler_data my_handler_data;
-  SCM answer;
+  SCM answer, old_winds;
-
-  /* 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;
-  }
 
   /* Exit caller's dynamic state.
    */
-  old_winds = scm_dynwinds;
+  old_winds = scm_i_dynwinds ();
-  scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
+  scm_dowinds (SCM_EOL, scm_ilength (old_winds));
-  SCM_DFRAME (old_rootcont) = scm_last_debug_frame;
-  scm_last_debug_frame = 0;
 
-  {
+  scm_frame_begin (SCM_F_FRAME_REWINDABLE);
-    my_handler_data.run_handler = 0;
+  scm_frame_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED));
-    answer = scm_internal_catch (SCM_BOOL_T,
-				 body, body_data,
-				 cwdr_handler, &my_handler_data);
-  }
 
+  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"
+	    "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.")
 #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"
 }
 

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,

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;
 

libguile/scmsigs.c

@@ -23,6 +23,7 @@
 #endif
 
 #include <signal.h>
+#include <stdio.h>
 #include <errno.h>
 
 #include "libguile/_scm.h"
@@ -69,21 +70,24 @@
 
 
 /* take_signal is installed as the C signal handler whenever a Scheme
-   handler is set.  when a signal arrives, take_signal will queue the
+   handler is set.  When a signal arrives, take_signal will write a
-   Scheme handler procedure for its thread.  */
+   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
+   contains the handler procedure or #f, signal_handler_asyncs
-   pre-queued cells for the handler (since we can't do fancy things
+   contains the thunk to be marked as an async when the signal arrives
-   during signal delivery), signal_cell_handlers contains the SCM
+   (or the cell with the thunk in a singlethreaded Guile), and
-   value to be stuffed into the pre-queued cell upon delivery, 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_handler_asyncs;
-static SCM signal_cell_handlers;
 static SCM signal_handler_threads;
 
 /* saves the original C handlers, when a new handler is installed.
@@ -94,34 +98,6 @@ static struct sigaction orig_handlers[NSIG];
 static SIGRETTYPE (*orig_handlers[NSIG])(int);
 #endif
 
-
-static SIGRETTYPE
-take_signal (int signum)
-{
-  if (signum >= 0 && signum < NSIG)
-    {
-      SCM cell = SCM_SIMPLE_VECTOR_REF (signal_handler_cells, signum);
-      SCM handler = SCM_SIMPLE_VECTOR_REF (signal_cell_handlers, signum);
-      SCM thread = SCM_SIMPLE_VECTOR_REF (signal_handler_threads, signum);
-      scm_root_state *root = scm_i_thread_root (thread);
-      if (scm_is_pair (cell))
-	{
-	  SCM_SETCAR (cell, handler);
-	  root->pending_asyncs = 1;
-	}
-    }
-  
-#ifndef HAVE_SIGACTION
-  signal (signum, take_signal);
-#endif
-}
-
-SCM
-scm_sigaction (SCM signum, SCM handler, SCM flags)
-{
-  return scm_sigaction_for_thread (signum, handler, flags, SCM_UNDEFINED);
-}
-
 static SCM
 close_1 (SCM proc, SCM arg)
 {
@@ -129,129 +105,121 @@ close_1 (SCM proc, SCM arg)
 					   scm_list_2 (proc, arg)));
 }
 
-/* Make sure that signal SIGNUM can be delivered to THREAD, using
+#if SCM_USE_PTHREAD_THREADS
-   HANDLER.  THREAD and HANDLER must either both be non-#f (which
-   means install the handler), or both #f (which means deinstall an
-   existing handler).
-*/
 
-struct install_handler_data {
+static int signal_pipe[2];
-  int signum;
+
-  SCM thread;
+static SIGRETTYPE
-  SCM handler;
+take_signal (int signum)
-};
+{
+  char sigbyte = signum;
+  write (signal_pipe[1], &sigbyte, 1);
+
+#ifndef HAVE_SIGACTION
+  signal (signum, take_signal);
+#endif
+}
 
 static SCM
-scm_delq_spine_x (SCM cell, SCM list)
+signal_delivery_thread (void *data)
 {
-  SCM s = list, prev = SCM_BOOL_F;
+  sigset_t all_sigs;
+  scm_t_guile_ticket ticket;
+  int n, sig;
+  char sigbyte;
 
-  while (!scm_is_eq (cell, s))
+  sigfillset (&all_sigs);
+  scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
+
+  while (1)
     {
-      if (scm_is_null (s))
+      ticket = scm_leave_guile ();
-	return list;
+      n = read (signal_pipe[0], &sigbyte, 1);
-      prev = s;
+      sig = sigbyte;
-      s = SCM_CDR (s);
+      scm_enter_guile (ticket);
-    }
+      if (n == 1 && sig >= 0 && sig < NSIG)
-  if (scm_is_false (prev))
+	{
-    return SCM_CDR (cell);
+	  SCM h, t;
-  else
+
-    {
+	  h = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, sig);
-      SCM_SETCDR (prev, SCM_CDR (cell));
+	  t = SCM_SIMPLE_VECTOR_REF (signal_handler_threads, sig);
-      return list;
+	  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 void *
+static void
-really_install_handler (void *data)
+start_signal_delivery_thread (void)
 {
-  struct install_handler_data *args = data;
+  if (pipe (signal_pipe) != 0)
-  int signum = args->signum;
+    scm_syserror (NULL);
-  SCM thread = args->thread;
+  scm_spawn_thread (signal_delivery_thread, NULL,
-  SCM handler = args->handler;
+		    scm_handle_by_message, "signal delivery thread");
-  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);
-    }
-
-  /* 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); 
-    }
-
-  /* Set the new 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);
-    }
-  else
-    {
-      SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, handler);
-      SCM_SIMPLE_VECTOR_SET (signal_cell_handlers, signum,
-			     close_1 (handler, scm_from_int (signum)));
-    }
-
-  /* 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;
 }
 
+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);
+}
+
+#else /* !SCM_USE_PTHREAD_THREADS */
+
+static SIGRETTYPE
+take_signal (int signum)
+{
+  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 (cell, t->active_asyncs);
+      t->active_asyncs = cell;
+      t->pending_asyncs = 1;
+    }
+
+#ifndef HAVE_SIGACTION
+  signal (signum, take_signal);
+#endif
+}
+
+static void
+ensure_signal_delivery_thread ()
+{
+  return;
+}
+
+#endif /* !SCM_USE_PTHREAD_THREADS */
+
 static void
 install_handler (int signum, SCM thread, SCM handler)
 {
-  /* We block asyncs while installing the handler.  It would be safe
+  if (scm_is_false (handler))
-     to leave them on, but we might run the wrong handler should a
+    {
-     signal be delivered. 
+      SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, SCM_BOOL_F);
-  */
+      SCM_SIMPLE_VECTOR_SET (signal_handler_asyncs, signum, SCM_BOOL_F);
+    }
+  else
+    {
+      SCM async = close_1 (handler, scm_from_int (signum));
+#if !SCM_USE_PTHREAD_THREADS
+      async = scm_cons (async, SCM_BOOL_F);
+#endif
+      SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, handler);
+      SCM_SIMPLE_VECTOR_SET (signal_handler_asyncs, signum, async);
+    }
 
-  struct install_handler_data args;
+  SCM_SIMPLE_VECTOR_SET (signal_handler_threads, signum, thread);
-  args.signum = signum;
+}
-  args.thread = thread;
+
-  args.handler = handler;
+SCM
-  scm_c_call_with_blocked_asyncs (really_install_handler, &args);
+scm_sigaction (SCM signum, SCM handler, SCM flags)
+{
+  return scm_sigaction_for_thread (signum, handler, flags, SCM_UNDEFINED);
 }
 
 /* user interface for installation of signal handlers.  */
@@ -323,19 +291,22 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
 	SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
     }
 
-  SCM_DEFER_INTS;
+  ensure_signal_delivery_thread ();
+
+  SCM_CRITICAL_SECTION_START;
   old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig);
   if (SCM_UNBNDP (handler))
     query_only = 1;
   else if (scm_is_integer (handler))
     {
-      if (SCM_NUM2LONG (2, handler) == (long) SIG_DFL
+      long handler_int = scm_to_long (handler);
-	  || SCM_NUM2LONG (2, handler) == (long) SIG_IGN)
+
+      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 =
+  signal_handler_asyncs =
-    scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
-  signal_cell_handlers =
     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));

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

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

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

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),
+  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
-		16, scm_cur_errp);
+
-  scm_puts (" of stack: 0x", scm_cur_errp);
+  scm_uintprint ((scm_stack_size (thread->continuation_base) 
-  scm_uintprint ((scm_t_bits) SCM_BASE (scm_rootcont), 16, scm_cur_errp);
+		  * sizeof (SCM_STACKITEM)),
-  scm_puts (" - 0x", scm_cur_errp);
+		 16, port);
-  scm_uintprint ((scm_t_bits) &stack, 16, scm_cur_errp);
+  scm_puts (" of stack: 0x", port);
-  scm_puts ("\n", scm_cur_errp);
+  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 ()
 {

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

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

libguile/stime.c

@@ -230,9 +230,9 @@ SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0,
 {
   timet timv;
 
-  SCM_DEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
   timv = time (NULL);
-  SCM_ALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
   if (timv == -1)
     SCM_MISC_ERROR ("current time not available", SCM_EOL);
   return scm_from_long (timv);
@@ -251,10 +251,10 @@ SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
   struct timeval time;
   int ret, err;
 
-  SCM_DEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
   ret = gettimeofday (&time, NULL);
   err = errno;
-  SCM_ALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
   if (ret == -1)
     {
       errno = err;
@@ -273,10 +273,10 @@ SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
   timet timv;
   int err;
 
-  SCM_DEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
   timv = time (NULL);
   err = errno;
-  SCM_ALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
   if (timv == -1)
     {
       errno = err;
@@ -375,7 +375,7 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
 
   /* deferring interupts is essential since a) setzone may install a temporary
      environment b) localtime uses a static buffer.  */
-  SCM_DEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
   oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 #ifdef LOCALTIME_CACHE
   tzset ();
@@ -428,7 +428,7 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
     zoff += 24 * 60 * 60;
 
   result = filltime (&lt, zoff, zname);
-  SCM_ALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
   if (zname)
     free (zname);
   return result;
@@ -461,11 +461,11 @@ SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
 #if HAVE_GMTIME_R
   bd_time = gmtime_r (&itime, &bd_buf);
 #else
-  SCM_DEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
   bd_time = gmtime (&itime);
   if (bd_time != NULL)
     bd_buf = *bd_time;
-  SCM_ALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
 #endif
   if (bd_time == NULL)
     SCM_SYSERROR;
@@ -531,7 +531,7 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
   scm_frame_free ((char *)lt.tm_zone);
 #endif
 
-  SCM_DEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
   oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 #ifdef LOCALTIME_CACHE
   tzset ();
@@ -584,7 +584,7 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
 
   result = scm_cons (scm_from_long (itime),
 		     filltime (&lt, zoff, zname));
-  SCM_ALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
   if (zname)
     free (zname);
 
@@ -667,7 +667,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
 						 SCM_EOL)));
 
 	have_zone = 1;
-	SCM_DEFER_INTS;
+	SCM_CRITICAL_SECTION_START;
 	oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
       }
 #endif
@@ -690,7 +690,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
     if (have_zone)
       {
 	restorezone (velts[10], oldenv, FUNC_NAME);
-	SCM_ALLOW_INTS;
+	SCM_CRITICAL_SECTION_END;
       }
 #endif
     }
@@ -743,11 +743,11 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
 
   /* GNU glibc strptime() "%s" is affected by the current timezone, since it
      reads a UTC time_t value and converts with localtime_r() to set the tm
-     fields, hence the use of SCM_DEFER_INTS.  */
+     fields, hence the use of SCM_CRITICAL_SECTION_START.  */
   t.tm_isdst = -1;
-  SCM_DEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
   rest = strptime (str, fmt, &t);
-  SCM_ALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
   if (rest == NULL)
     {
       /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for

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

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)

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

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

libguile/threads.h

@@ -27,165 +27,123 @@
 #include "libguile/throw.h"
 #include "libguile/root.h"
 #include "libguile/iselect.h"
-#include "libguile/threads-plugin.h"
+#include "libguile/dynwind.h"
+
+#if SCM_USE_PTHREAD_THREADS
+#include "libguile/pthread-threads.h"
+#endif
+
+#if SCM_USE_NULL_THREADS
+#include "libguile/null-threads.h"
+#endif
+
 
 
 /* smob tags for the thread datatypes */
 SCM_API scm_t_bits scm_tc16_thread;
 SCM_API scm_t_bits scm_tc16_mutex;
-SCM_API scm_t_bits scm_tc16_fair_mutex;
 SCM_API scm_t_bits scm_tc16_condvar;
-SCM_API scm_t_bits scm_tc16_fair_condvar;
 
-#define SCM_THREADP(x)        SCM_SMOB_PREDICATE (scm_tc16_thread, x)
+typedef struct scm_i_thread {
-#define SCM_THREAD_DATA(x)    ((scm_thread *) SCM_SMOB_DATA (x))
+  struct scm_i_thread *next_thread;
 
-#define SCM_MUTEXP(x)         SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
+  SCM handle;
-#define SCM_FAIR_MUTEX_P(x)   SCM_SMOB_PREDICATE (scm_tc16_fair_mutex, x)
+  scm_i_pthread_t pthread;
-#define SCM_MUTEX_DATA(x)     ((void *) SCM_SMOB_DATA (x))
   
-#define SCM_CONDVARP(x)       SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
+  SCM join_queue;
-#define SCM_FAIR_CONDVAR_P(x) SCM_SMOB_PREDICATE (scm_tc16_fair_condvar, x)
+  SCM result;
-#define SCM_CONDVAR_DATA(x)   ((void *) SCM_SMOB_DATA (x))
+  int exited;
+
+  SCM sleep_object;
+  scm_i_pthread_mutex_t *sleep_mutex;
+  scm_i_pthread_cond_t sleep_cond;
+  int sleep_fd, sleep_pipe[2];
+
+  /* This mutex represents this threads right to access the heap.
+     That right can temporarily be taken away by the GC.  
+  */
+  scm_i_pthread_mutex_t heap_mutex;
+
+  /* The freelists of this thread.  Each thread has its own lists so
+     that they can all allocate concurrently.
+  */
+  SCM freelist, freelist2;
+  int clear_freelists_p; /* set if GC was done while thread was asleep */
+
+  /* Other thread local things.
+   */
+  SCM dynamic_state;
+  scm_t_debug_frame *last_debug_frame;
+  SCM dynwinds;
+
+  /* For system asyncs.
+   */
+  SCM active_asyncs;            /* The thunks to be run at the next
+                                   safe point */
+  SCM signal_asyncs;            /* The pre-queued cells for signal handlers.
+                                 */
+  unsigned int block_asyncs;    /* Non-zero means that asyncs should 
+                                   not be run. */
+  unsigned int pending_asyncs;  /* Non-zero means that asyncs might be pending.
+				 */
+
+  /* The current continuation root and the stack base for it.
+
+     The continuation root is an arbitrary but unique object that
+     identifies a dynamic extent.  Continuations created during that
+     extent can also only be invoked during it.
+
+     We use pairs where the car is the thread handle and the cdr links
+     to the previous pair.  This might be used for better error
+     messages but is not essential for identifying continuation roots.
+
+     The continuation base is the far end of the stack upto which it
+     needs to be copied.
+  */
+  SCM continuation_root;
+  SCM_STACKITEM *continuation_base;
+
+  /* For keeping track of the stack and registers. */
+  SCM_STACKITEM *base;
+  SCM_STACKITEM *top;
+  jmp_buf regs;
+
+} scm_i_thread;
+
+#define SCM_I_IS_THREAD(x)    SCM_SMOB_PREDICATE (scm_tc16_thread, x)
+#define SCM_I_THREAD_DATA(x)  ((scm_i_thread *) SCM_SMOB_DATA (x))
 
 #define SCM_VALIDATE_THREAD(pos, a) \
- SCM_MAKE_VALIDATE_MSG (pos, a, THREADP, "thread")
+  scm_assert_smob_type (scm_tc16_thread, (a))
-
 #define SCM_VALIDATE_MUTEX(pos, a) \
- SCM_ASSERT_TYPE (SCM_MUTEXP (a) || SCM_FAIR_MUTEX_P (a), \
+  scm_assert_smob_type (scm_tc16_mutex, (a))
-                  a, pos, FUNC_NAME, "mutex");
-
 #define SCM_VALIDATE_CONDVAR(pos, a) \
- SCM_ASSERT_TYPE (SCM_CONDVARP (a) || SCM_FAIR_CONDVAR_P (a), \
+  scm_assert_smob_type (scm_tc16_condvar, (a))
-                  a, pos, FUNC_NAME, "condition variable");
 
-SCM_API void scm_threads_mark_stacks (void);
-SCM_API void scm_init_threads (SCM_STACKITEM *);
-SCM_API void scm_init_thread_procs (void);
-
-#if SCM_USE_PTHREAD_THREADS
-# include "libguile/pthread-threads.h"
-#else
-# include "libguile/null-threads.h"
-#endif
-
-/*----------------------------------------------------------------------*/
-/* Low-level C API */
-
-/* The purpose of this API is seamless, simple and thread package
-   independent interaction with Guile threads from the application.
-
-   Note that Guile also uses it to implement itself, just like
-   with the rest of the application API.
- */
-
-/* MDJ 021209 <djurfeldt@nada.kth.se>:
-   The separation of the plugin interface (currently in
-   pthread-threads.h and null-threads.h) and the low-level C API needs
-   to be completed in a sensible way.
- */
-
-/* Deprecate this name and rename to scm_thread_create?
-   Introduce the other two arguments in pthread_create to prepare for
-   the future?
- */
 SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data,
 			      scm_t_catch_handler handler, void *handler_data);
-SCM_API scm_t_thread scm_c_scm2thread (SCM thread);
 
-#define scm_thread_join		scm_i_plugin_thread_join
+typedef void *scm_t_guile_ticket;
-#define scm_thread_detach	scm_i_plugin_thread_detach
+SCM_API void scm_enter_guile (scm_t_guile_ticket ticket);
-#define scm_thread_self		scm_i_plugin_thread_self
+SCM_API scm_t_guile_ticket scm_leave_guile (void);
-#define scm_thread_yield	scm_i_plugin_thread_yield
+SCM_API void *scm_without_guile (void *(*func)(void *), void *data);
 
-#define scm_mutex_init		scm_i_plugin_mutex_init 
+SCM_API void *scm_with_guile (void *(*func)(void *), void *data);
-#define scm_mutex_destroy	scm_i_plugin_mutex_destroy
+SCM_API void *scm_i_with_guile_and_parent (void *(*func)(void *), void *data,
-SCM_API int scm_mutex_lock (scm_t_mutex *m);
+					   SCM parent);
-#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
+/* XXX - every critical section needs to be examined and protected
-   lazy to allocate a specific mutex. */
+   with scm_frame_critical_section, say.
-extern scm_t_mutex scm_i_critical_section_mutex;
+*/
+
+extern scm_i_pthread_mutex_t scm_i_critical_section_mutex;
 
 #define SCM_CRITICAL_SECTION_START \
-  scm_mutex_lock (&scm_i_critical_section_mutex)
+  scm_i_pthread_mutex_lock (&scm_i_critical_section_mutex)
 #define SCM_CRITICAL_SECTION_END \
-  scm_mutex_unlock (&scm_i_critical_section_mutex)
+  scm_i_pthread_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;
 
@@ -193,8 +151,15 @@ void scm_i_thread_put_to_sleep (void);
 void scm_i_thread_wake_up (void);
 void scm_i_thread_invalidate_freelists (void);
 void scm_i_thread_sleep_for_gc (void);
-void scm_threads_prehistory (void);
+SCM_API void scm_i_frame_single_threaded (void);
+
+void scm_threads_prehistory (SCM_STACKITEM *);
 void scm_threads_init_first_thread (void);
+SCM_API void scm_threads_mark_stacks (void);
+SCM_API void scm_init_threads (void);
+SCM_API void scm_init_thread_procs (void);
+SCM_API void scm_init_threads_default_dynamic_state (void);
+
 
 #define SCM_THREAD_SWITCHING_CODE \
 do { \
@@ -202,21 +167,17 @@ do { \
     scm_i_thread_sleep_for_gc (); \
 } while (0)
 
-SCM scm_i_create_thread (scm_t_catch_body body, void *body_data,
-			 scm_t_catch_handler handler, void *handler_data,
-			 SCM protects);
-
-/* The C versions of the Scheme-visible thread functions.  */
 SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler);
 SCM_API SCM scm_yield (void);
 SCM_API SCM scm_join_thread (SCM t);
+
 SCM_API SCM scm_make_mutex (void);
-SCM_API SCM scm_make_fair_mutex (void);
+SCM_API SCM scm_make_recursive_mutex (void);
 SCM_API SCM scm_lock_mutex (SCM m);
 SCM_API SCM scm_try_mutex (SCM m);
 SCM_API SCM scm_unlock_mutex (SCM m);
+
 SCM_API SCM scm_make_condition_variable (void);
-SCM_API SCM scm_make_fair_condition_variable (void);
 SCM_API SCM scm_wait_condition_variable (SCM cond, SCM mutex);
 SCM_API SCM scm_timed_wait_condition_variable (SCM cond, SCM mutex,
 					       SCM abstime);
@@ -229,20 +190,39 @@ SCM_API SCM scm_all_threads (void);
 SCM_API int scm_c_thread_exited_p (SCM thread);
 SCM_API SCM scm_thread_exited_p (SCM thread);
 
-SCM_API scm_root_state *scm_i_thread_root (SCM thread);
+SCM_API void scm_frame_critical_section (void);
 
-#define SCM_CURRENT_THREAD \
+#define SCM_I_CURRENT_THREAD \
-  ((scm_thread *) scm_i_plugin_getspecific (scm_i_thread_key))
+  ((scm_i_thread *) scm_i_pthread_getspecific (scm_i_thread_key))
-extern scm_t_key scm_i_thread_key;
+SCM_API scm_i_pthread_key_t scm_i_thread_key;
 
-/* These macros have confusing names.
+#define scm_i_dynwinds()         (SCM_I_CURRENT_THREAD->dynwinds)
-   They really refer to the root state of the running thread. */
+#define scm_i_set_dynwinds(w)    (SCM_I_CURRENT_THREAD->dynwinds = (w))
-#define SCM_THREAD_LOCAL_DATA (scm_getspecific (scm_i_root_state_key))
+#define scm_i_last_debug_frame() (SCM_I_CURRENT_THREAD->last_debug_frame)
-#define SCM_SET_THREAD_LOCAL_DATA(x) scm_i_set_thread_data(x)
+#define scm_i_set_last_debug_frame(f) \
-SCM_API scm_t_key scm_i_root_state_key;
+                                 (SCM_I_CURRENT_THREAD->last_debug_frame = (f))
-SCM_API void scm_i_set_thread_data (void *);
 
-SCM_API scm_t_mutex scm_i_misc_mutex;
+SCM_API scm_i_pthread_mutex_t scm_i_misc_mutex;
+
+/* Convenience functions for working with the pthread API in guile
+   mode.
+*/
+
+#if SCM_USE_PTHREAD_THREADS
+SCM_API int scm_pthread_mutex_lock (pthread_mutex_t *mutex);
+SCM_API void scm_frame_pthread_mutex_lock (pthread_mutex_t *mutex);
+SCM_API int scm_pthread_cond_wait (pthread_cond_t *cond,
+				   pthread_mutex_t *mutex);
+SCM_API int scm_pthread_cond_timedwait (pthread_cond_t *cond,
+					pthread_mutex_t *mutex,
+					const struct timespec *abstime);
+#endif
+
+/* More convenience functions.
+ */
+
+SCM_API unsigned int scm_std_sleep (unsigned int);
+SCM_API unsigned long scm_std_usleep (unsigned long);
 
 #endif  /* SCM_THREADS_H */
 

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_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
-      SCM_REALLOW_INTS;
+      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_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
-      SCM_REALLOW_INTS;
+      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_CRITICAL_SECTION_START;
-  scm_dynwinds = scm_acons (tag, lazy_catch, scm_dynwinds);
+  scm_i_set_dynwinds (scm_acons (tag, lazy_catch, scm_i_dynwinds ()));
-  SCM_REALLOW_INTS;
+  SCM_CRITICAL_SECTION_END;
 
   answer = (*body) (body_data);
 
-  SCM_REDEFER_INTS;
+  SCM_CRITICAL_SECTION_START;
-  scm_dynwinds = SCM_CDR (scm_dynwinds);
+  scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
-  SCM_REALLOW_INTS;
+  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;
+      SCM_CRITICAL_SECTION_START;
-      handle = scm_dynwinds;
+      handle = scm_i_dynwinds ();
-      scm_dynwinds = SCM_CDR (scm_dynwinds);
+      scm_i_set_dynwinds (SCM_CDR (handle));
-      SCM_REALLOW_INTS;
+      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);
     }
 

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

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

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