* gen-scmconfig.h.in (SCM_I_GSC_HAVE_ARRAYS): Removed.
[bpt/guile.git] / libguile / threads.c
index 06fe64d..b772b84 100644 (file)
@@ -1,43 +1,19 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc.
  * 
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- * 
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
- * GNU General Public License for more details.
- * 
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING.  If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
  *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE.  If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way.  To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
  *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.  */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
 
 
 \f
    C level threads.
 */
 
+#include "libguile/_scm.h"
+
+#if HAVE_UNISTD_H
 #include <unistd.h>
+#endif
 #include <stdio.h>
 #include <assert.h>
+#if HAVE_SYS_TIME_H
 #include <sys/time.h>
+#endif
 
-#include "libguile/_scm.h"
 #include "libguile/validate.h"
 #include "libguile/root.h"
 #include "libguile/eval.h"
@@ -73,7 +54,7 @@ static SCM
 enqueue (SCM q, SCM t)
 {
   SCM c = scm_cons (t, SCM_EOL);
-  if (SCM_NULLP (SCM_CDR (q)))
+  if (scm_is_null (SCM_CDR (q)))
     SCM_SETCDR (q, c);
   else
     SCM_SETCDR (SCM_CAR (q), c);
@@ -85,11 +66,11 @@ static void
 remqueue (SCM q, SCM c)
 {
   SCM p, prev = q;
-  for (p = SCM_CDR (q); !SCM_NULLP (p); p = SCM_CDR (p))
+  for (p = SCM_CDR (q); !scm_is_null (p); p = SCM_CDR (p))
     {
-      if (SCM_EQ_P (p, c))
+      if (scm_is_eq (p, c))
        {
-         if (SCM_EQ_P (c, SCM_CAR (q)))
+         if (scm_is_eq (c, SCM_CAR (q)))
            SCM_SETCAR (q, SCM_CDR (c));
          SCM_SETCDR (prev, SCM_CDR (c));
          return;
@@ -103,12 +84,12 @@ static SCM
 dequeue (SCM q)
 {
   SCM c = SCM_CDR (q);
-  if (SCM_NULLP (c))
+  if (scm_is_null (c))
     return SCM_BOOL_F;
   else
     {
       SCM_SETCDR (q, SCM_CDR (c));
-      if (SCM_NULLP (SCM_CDR (q)))
+      if (scm_is_null (SCM_CDR (q)))
        SCM_SETCAR (q, SCM_EOL);
       return SCM_CAR (c);
     }
@@ -136,8 +117,6 @@ struct scm_thread {
   SCM result;
   int exited;
 
-  SCM joining_threads;
-
   /* For keeping track of the stack and registers. */
   SCM_STACKITEM *base;
   SCM_STACKITEM *top;
@@ -155,9 +134,8 @@ make_thread (SCM creation_protects)
   t->handle = z;
   t->result = creation_protects;
   t->base = NULL;
-  t->joining_threads = make_queue ();
   scm_i_plugin_cond_init (&t->sleep_cond, 0);
-  scm_i_plugin_mutex_init (&t->heap_mutex, 0);
+  scm_i_plugin_mutex_init (&t->heap_mutex, &scm_i_plugin_mutex);
   t->clear_freelists_p = 0;
   t->exited = 0;
   return z;
@@ -178,7 +156,6 @@ thread_mark (SCM obj)
 {
   scm_thread *t = SCM_THREAD_DATA (obj);
   scm_gc_mark (t->result);
-  scm_gc_mark (t->joining_threads);
   return t->root->handle; /* mark root-state of this thread */
 }
 
@@ -187,8 +164,10 @@ thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 {
   scm_thread *t = SCM_THREAD_DATA (exp);
   scm_puts ("#<thread ", port);
-  scm_intprint ((unsigned long)t, 16, port);
-  scm_putc ('>', port);
+  scm_uintprint ((size_t)t->thread, 10, port);
+  scm_puts (" (", port);
+  scm_uintprint ((scm_t_bits)t, 16, port);
+  scm_puts (")>", port);
   return 1;
 }
 
@@ -241,7 +220,7 @@ suspend ()
   scm_thread *c = SCM_CURRENT_THREAD;
 
   /* record top of stack for the GC */
-  c->top = (SCM_STACKITEM *)&c;
+  c->top = SCM_STACK_PTR (&c);
   /* save registers. */
   SCM_FLUSH_REGISTER_WINDOWS;
   setjmp (c->regs);
@@ -274,7 +253,7 @@ block ()
    reached.  Return 0 when it has been unblocked; errno otherwise.
  */
 static int
-timed_block (const struct timespec *at)
+timed_block (const scm_t_timespec *at)
 {
   int err;
   scm_thread *t = suspend ();
@@ -341,21 +320,22 @@ really_launch (SCM_STACKITEM *base, launch_data *data)
                       data,
                       (scm_t_catch_handler) handler_bootstrip,
                       data, base);
+  scm_i_leave_guile (); /* release the heap */
   free (data);
 
-  scm_thread_detach (t->thread);
   scm_i_plugin_mutex_lock (&thread_admin_mutex);
   all_threads = scm_delq_x (thread, all_threads);
   t->exited = 1;
   thread_count--;
+  /* detach before unlocking in order to not become joined when detached */
+  scm_thread_detach (t->thread);
   scm_i_plugin_mutex_unlock (&thread_admin_mutex);
-  /* We're leaving with heap_mutex still locked. */
 }
 
 static void *
 launch_thread (void *p)
 {
-  really_launch ((SCM_STACKITEM *)&p, (launch_data *)p);
+  really_launch (SCM_STACK_PTR (&p), (launch_data *) p);
   return 0;
 }
 
@@ -374,15 +354,11 @@ create_thread (scm_t_catch_body body, void *body_data,
 
   {
     scm_t_thread th;
-    SCM root, old_winds, new_threads;
+    SCM root;
     launch_data *data;
     scm_thread *t;
     int err;
 
-    /* Unwind wind chain. */
-    old_winds = scm_dynwinds;
-    scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
-
     /* Allocate thread locals. */
     root = scm_make_root (scm_root->handle);
     data = scm_malloc (sizeof (launch_data));
@@ -398,16 +374,27 @@ create_thread (scm_t_catch_body body, void *body_data,
     /* must initialize root state pointer before the thread is linked
        into all_threads */
     t->root = SCM_ROOT_STATE (root);
+    /* disconnect from parent, to prevent remembering dead threads */
+    t->root->parent = SCM_BOOL_F;
+    /* start with an empty dynwind chain */
+    t->root->dynwinds = SCM_EOL;
     
     /* In order to avoid the need of synchronization between parent
        and child thread, we need to insert the child into all_threads
        before creation. */
-    new_threads = scm_cons (thread, SCM_BOOL_F); /* could cause GC */
-    scm_i_plugin_mutex_lock (&thread_admin_mutex);
-    SCM_SETCDR (new_threads, all_threads);
-    all_threads = new_threads;
-    thread_count++;
-    scm_i_plugin_mutex_unlock (&thread_admin_mutex);
+    {
+      SCM new_threads = scm_cons (thread, SCM_BOOL_F); /* could cause GC */
+      scm_thread *parent = scm_i_leave_guile (); /* to prevent deadlock */
+      scm_i_plugin_mutex_lock (&thread_admin_mutex);
+      SCM_SETCDR (new_threads, all_threads);
+      all_threads = new_threads;
+      thread_count++;
+      scm_i_plugin_mutex_unlock (&thread_admin_mutex);
+
+      scm_remember_upto_here_1 (root);
+      
+      scm_i_enter_guile (parent);
+    }
     
     err = scm_i_plugin_thread_create (&th, 0, launch_thread, (void *) data);
     if (err != 0)
@@ -419,9 +406,6 @@ create_thread (scm_t_catch_body body, void *body_data,
        scm_i_plugin_mutex_unlock (&thread_admin_mutex);
       }
 
-    /* Return to old dynamic context. */
-    scm_dowinds (old_winds, - scm_ilength (old_winds));
-
     if (err)
       {
        errno = err;
@@ -434,7 +418,7 @@ create_thread (scm_t_catch_body body, void *body_data,
 
 SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 2, 0, 0,
            (SCM thunk, SCM handler),
-"Evaluate @var{(thunk)} in a new thread, and new dynamic context, "
+"Evaluate @code{(@var{thunk})} in a new thread, and new dynamic context, "
 "returning a new thread object representing the thread. "
 "If an error occurs during evaluation, call error-thunk, passing it an "
 "error code describing the condition. "
@@ -444,8 +428,8 @@ SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 2, 0, 0,
 "All the evaluation rules for dynamic roots apply to threads.")
 #define FUNC_NAME s_scm_call_with_new_thread
 {
-  SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), thunk, SCM_ARG1, FUNC_NAME);
-  SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)), handler, SCM_ARG2,
+  SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), thunk, SCM_ARG1, FUNC_NAME);
+  SCM_ASSERT (scm_is_true (scm_procedure_p (handler)), handler, SCM_ARG2,
              FUNC_NAME);
 
   return create_thread ((scm_t_catch_body) scm_call_0, thunk,
@@ -454,6 +438,15 @@ SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 2, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_yield, "yield", 0, 0, 0,
+           (),
+"Move the calling thread to the end of the scheduling queue.")
+#define FUNC_NAME s_scm_yield
+{
+  return scm_from_bool (scm_thread_yield ());
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
            (SCM thread),
 "Suspend execution of the calling thread until the target @var{thread} "
@@ -464,15 +457,16 @@ SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
   SCM res;
 
   SCM_VALIDATE_THREAD (1, thread);
-  if (SCM_EQ_P (cur_thread, thread))
+  if (scm_is_eq (cur_thread, thread))
     SCM_MISC_ERROR ("can not join the current thread", SCM_EOL);
 
   t = SCM_THREAD_DATA (thread);
   if (!t->exited)
     {
-      scm_thread *c = scm_i_leave_guile ();
+      scm_thread *c;
+      c = scm_i_leave_guile ();
       while (!THREAD_INITIALIZED_P (t))
-       SCM_TICK;
+       scm_i_plugin_thread_yield ();
       scm_thread_join (t->thread, 0);
       scm_i_enter_guile (c);
     }
@@ -516,7 +510,7 @@ SCM_DEFINE (scm_make_fair_mutex, "make-fair-mutex", 0, 0, 0,
 {
   SCM mx = scm_make_smob (scm_tc16_fair_mutex);
   fair_mutex *m = SCM_MUTEX_DATA (mx);
-  scm_i_plugin_mutex_init (&m->lock, 0);
+  scm_i_plugin_mutex_init (&m->lock, &scm_i_plugin_mutex);
   m->lockedp = 0;
   m->owner = SCM_BOOL_F;
   m->level = 0;
@@ -598,7 +592,7 @@ fair_mutex_unlock (fair_mutex *m)
   else
     {
       SCM next = dequeue (m->waiting);
-      if (!SCM_FALSEP (next))
+      if (scm_is_true (next))
        {
          m->owner = next;
          unblock (SCM_THREAD_DATA (next));
@@ -645,7 +639,7 @@ SCM_DEFINE (scm_make_fair_condition_variable, "make-fair-condition-variable", 0,
 static int
 fair_cond_timedwait (fair_cond *c,
                     fair_mutex *m,
-                    const struct timespec *waittime)
+                    const scm_t_timespec *waittime)
 {
   int err;
   scm_i_plugin_mutex_lock (&c->lock);
@@ -673,7 +667,7 @@ fair_cond_signal (fair_cond *c)
 {
   SCM th;
   scm_i_plugin_mutex_lock (&c->lock);
-  if (!SCM_FALSEP (th = dequeue (c->waiting)))
+  if (scm_is_true (th = dequeue (c->waiting)))
     unblock (SCM_THREAD_DATA (th));
   scm_i_plugin_mutex_unlock (&c->lock);
   return 0;
@@ -684,7 +678,7 @@ fair_cond_broadcast (fair_cond *c)
 {
   SCM th;
   scm_i_plugin_mutex_lock (&c->lock);
-  while (!SCM_FALSEP (th = dequeue (c->waiting)))
+  while (scm_is_true (th = dequeue (c->waiting)))
     unblock (SCM_THREAD_DATA (th));
   scm_i_plugin_mutex_unlock (&c->lock);
   return 0;
@@ -698,7 +692,7 @@ SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0,
 #define FUNC_NAME s_scm_make_mutex
 {
   SCM mx = scm_make_smob (scm_tc16_mutex);
-  scm_i_plugin_mutex_init (SCM_MUTEX_DATA (mx), 0);
+  scm_i_plugin_mutex_init (SCM_MUTEX_DATA (mx), &scm_i_plugin_mutex);
   return mx;
 }
 #undef FUNC_NAME
@@ -721,9 +715,7 @@ SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
   else
     {
       scm_t_mutex *m = SCM_MUTEX_DATA (mx);
-      scm_thread *t = scm_i_leave_guile ();
-      err = scm_i_plugin_mutex_lock (m);
-      scm_i_enter_guile (t);
+      err = scm_mutex_lock (m);
     }
 
   if (err)
@@ -749,9 +741,7 @@ SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0,
   else
     {
       scm_t_mutex *m = SCM_MUTEX_DATA (mx);
-      scm_thread *t = scm_i_leave_guile ();
-      err = scm_i_plugin_mutex_trylock (m);
-      scm_i_enter_guile (t);
+      err = scm_mutex_trylock (m);
     }
 
   if (err == EBUSY)
@@ -799,7 +789,7 @@ SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0,
   else
     {
       scm_t_mutex *m = SCM_MUTEX_DATA (mx);
-      err = scm_i_plugin_mutex_unlock (m);
+      err = scm_mutex_unlock (m);
     }
 
   if (err)
@@ -837,7 +827,7 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1,
 "is returned. ")
 #define FUNC_NAME s_scm_timed_wait_condition_variable
 {
-  struct timespec waittime;
+  scm_t_timespec waittime;
   int err;
 
   SCM_VALIDATE_CONDVAR (1, cv);
@@ -851,7 +841,7 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1,
   
   if (!SCM_UNBNDP (t))
     {
-      if (SCM_CONSP (t))
+      if (scm_is_pair (t))
        {
          SCM_VALIDATE_UINT_COPY (3, SCM_CAR (t), waittime.tv_sec);
          SCM_VALIDATE_UINT_COPY (3, SCM_CDR (t), waittime.tv_nsec);
@@ -872,13 +862,16 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1,
     {
       scm_t_cond *c = SCM_CONDVAR_DATA (cv);
       scm_t_mutex *m = SCM_MUTEX_DATA (mx);
-      scm_thread *t = scm_i_leave_guile ();
-      err = scm_i_plugin_cond_wait (c, m);
-      scm_i_enter_guile (t);
+      if (SCM_UNBNDP (t))
+       err = scm_cond_wait (c, m);
+      else
+       err = scm_cond_timedwait (c, m, &waittime);
     }
 
   if (err)
     {
+      if (err == ETIMEDOUT)
+       return SCM_BOOL_F;
       errno = err;
       SCM_SYSERROR;
     }
@@ -897,7 +890,7 @@ SCM_DEFINE (scm_signal_condition_variable, "signal-condition-variable", 1, 0, 0,
   else
     {
       scm_t_cond *c = SCM_CONDVAR_DATA (cv);
-      scm_i_plugin_cond_signal (c);
+      scm_cond_signal (c);
     }
   return SCM_BOOL_T;
 }
@@ -914,7 +907,7 @@ SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1,
   else
     {
       scm_t_cond *c = SCM_CONDVAR_DATA (cv);
-      scm_i_plugin_cond_broadcast (c);
+      scm_cond_broadcast (c);
     }
   return SCM_BOOL_T;
 }
@@ -944,7 +937,8 @@ void
 scm_threads_mark_stacks (void)
 {
   volatile SCM c;
-  for (c = all_threads; !SCM_NULLP (c); c = SCM_CDR (c))
+
+  for (c = all_threads; !scm_is_null (c); c = SCM_CDR (c))
     {
       scm_thread *t = SCM_THREAD_DATA (SCM_CAR (c));
       if (!THREAD_INITIALIZED_P (t))
@@ -952,75 +946,27 @@ scm_threads_mark_stacks (void)
          /* Not fully initialized yet. */
          continue;
        }
+
       if (t->top == NULL)
        {
-         long stack_len;
-#ifdef SCM_DEBUG
-         if (t->thread != scm_thread_self ())
-           abort ();
-#endif
-         /* Active thread */
-         /* stack_len is long rather than sizet in order to guarantee
-            that &stack_len is long aligned */
-#ifdef STACK_GROWS_UP
-         stack_len = ((SCM_STACKITEM *) (&t) -
-                      (SCM_STACKITEM *) thread->base);
-         
-         /* Protect from the C stack.  This must be the first marking
-          * done because it provides information about what objects
-          * are "in-use" by the C code.   "in-use" objects are  those
-          * for which the information about length and base address must
-          * remain usable.   This requirement is stricter than a liveness
-          * requirement -- in particular, it constrains the implementation
-          * of scm_resizuve.
-          */
-         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_save_regs_gc_mark
-                              / sizeof (SCM_STACKITEM)));
-         
-         scm_mark_locations (((size_t) t->base,
-                              (sizet) stack_len));
-#else
-         stack_len = ((SCM_STACKITEM *) t->base -
-                      (SCM_STACKITEM *) (&t));
-         
-         /* Protect from the C stack.  This must be the first marking
-          * done because it provides information about what objects
-          * are "in-use" by the C code.   "in-use" objects are  those
-          * for which the information about length and base address must
-          * remain usable.   This requirement is stricter than a liveness
-          * requirement -- in particular, it constrains the implementation
-          * of scm_resizuve.
+         /* Thread has not been suspended, which should never happen.
           */
-         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_save_regs_gc_mark
-                              / sizeof (SCM_STACKITEM)));
-         
-         scm_mark_locations ((SCM_STACKITEM *) &t,
-                             stack_len);
-#endif
+         abort ();
        }
-      else
-       {
-         /* Suspended thread */
-#ifdef STACK_GROWS_UP
-         long stack_len = t->top - t->base;
-         scm_mark_locations (t->base, stack_len);
+
+      {
+#if SCM_STACK_GROWS_UP
+       scm_mark_locations (t->base, t->top - t->base);
 #else
-         long stack_len = t->base - t->top;
-         scm_mark_locations (t->top, stack_len);
+       scm_mark_locations (t->top, t->base - t->top);
 #endif
-         scm_mark_locations ((SCM_STACKITEM *) t->regs,
-                             ((size_t) sizeof(t->regs)
-                              / sizeof (SCM_STACKITEM)));
-       }
+      }
+      scm_mark_locations ((SCM_STACKITEM *) t->regs,
+                         ((size_t) sizeof(t->regs)
+                          / sizeof (SCM_STACKITEM)));
     }
+
+  SCM_MARK_BACKING_STORE ();
 }
 
 /*** Select */
@@ -1051,6 +997,12 @@ scm_spawn_thread (scm_t_catch_body body, void *body_data,
   return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F);
 }
 
+scm_t_thread
+scm_c_scm2thread (SCM thread)
+{
+  return SCM_THREAD_DATA (thread)->thread;
+}
+
 int
 scm_mutex_lock (scm_t_mutex *m)
 {
@@ -1060,6 +1012,30 @@ scm_mutex_lock (scm_t_mutex *m)
   return res;
 }
 
+scm_t_rec_mutex *
+scm_make_rec_mutex ()
+{
+  scm_t_rec_mutex *m = scm_malloc (sizeof (scm_t_rec_mutex));
+  scm_i_plugin_rec_mutex_init (m, &scm_i_plugin_rec_mutex);
+  return m;
+}
+
+void
+scm_rec_mutex_free (scm_t_rec_mutex *m)
+{
+  scm_i_plugin_rec_mutex_destroy (m);
+  free (m);
+}
+
+int
+scm_rec_mutex_lock (scm_t_rec_mutex *m)
+{
+  scm_thread *t = scm_i_leave_guile ();
+  int res = scm_i_plugin_rec_mutex_lock (m);
+  scm_i_enter_guile (t);
+  return res;  
+}
+
 int
 scm_cond_wait (scm_t_cond *c, scm_t_mutex *m)
 {
@@ -1070,7 +1046,7 @@ scm_cond_wait (scm_t_cond *c, scm_t_mutex *m)
 }
 
 int
-scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m, const struct timespec *wt)
+scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m, const scm_t_timespec *wt)
 {
   scm_thread *t = scm_i_leave_guile ();
   int res = scm_i_plugin_cond_timedwait (c, m, wt);
@@ -1078,6 +1054,18 @@ scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m, const struct timespec *wt)
   return res;
 }
 
+void *
+scm_getspecific (scm_t_key k)
+{
+  return scm_i_plugin_getspecific (k);
+}
+
+int
+scm_setspecific (scm_t_key k, void *s)
+{
+  return scm_i_plugin_setspecific (k, s);
+}
+
 void
 scm_enter_guile ()
 {
@@ -1126,7 +1114,7 @@ SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0,
            "Return a list of all threads.")
 #define FUNC_NAME s_scm_all_threads
 {
-  return all_threads;
+  return scm_list_copy (all_threads);
 }
 #undef FUNC_NAME
 
@@ -1141,7 +1129,7 @@ SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0,
            "Return @code{#t} iff @var{thread} has exited.\n")
 #define FUNC_NAME s_scm_thread_exited_p
 {
-  return SCM_BOOL (scm_c_thread_exited_p (thread));
+  return scm_from_bool (scm_c_thread_exited_p (thread));
 }
 #undef FUNC_NAME
 
@@ -1158,26 +1146,29 @@ scm_c_thread_exited_p (SCM thread)
 
 static scm_t_cond wake_up_cond;
 int scm_i_thread_go_to_sleep;
-static scm_t_mutex gc_section_mutex;
-static scm_thread *gc_section_owner;
-static int gc_section_count = 0;
 static int threads_initialized_p = 0;
 
 void
 scm_i_thread_put_to_sleep ()
 {
-  SCM_REC_CRITICAL_SECTION_START (gc_section);
-  if (threads_initialized_p && gc_section_count == 1)
+  if (threads_initialized_p)
     {
-      SCM threads = all_threads;
+      SCM threads;
+
+      /* We leave Guile completely before locking the
+        thread_admin_mutex.  This ensures that other threads can put
+        us to sleep while we block on that mutex.
+      */
+      scm_i_leave_guile ();
+      scm_i_plugin_mutex_lock (&thread_admin_mutex);
+      threads = all_threads;
       /* Signal all threads to go to sleep */
       scm_i_thread_go_to_sleep = 1;
-      for (; !SCM_NULLP (threads); threads = SCM_CDR (threads))
-       if (SCM_CAR (threads) != cur_thread)
-         {
-           scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
-           scm_i_plugin_mutex_lock (&t->heap_mutex);
-         }
+      for (; !scm_is_null (threads); threads = SCM_CDR (threads))
+       {
+         scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
+         scm_i_plugin_mutex_lock (&t->heap_mutex);
+       }
       scm_i_thread_go_to_sleep = 0;
     }
 }
@@ -1185,8 +1176,9 @@ scm_i_thread_put_to_sleep ()
 void
 scm_i_thread_invalidate_freelists ()
 {
+  /* Don't need to lock thread_admin_mutex here since we are single threaded */
   SCM threads = all_threads;
-  for (; !SCM_NULLP (threads); threads = SCM_CDR (threads))
+  for (; !scm_is_null (threads); threads = SCM_CDR (threads))
     if (SCM_CAR (threads) != cur_thread)
       {
        scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
@@ -1197,18 +1189,19 @@ scm_i_thread_invalidate_freelists ()
 void
 scm_i_thread_wake_up ()
 {
-  if (threads_initialized_p && gc_section_count == 1)
+  if (threads_initialized_p)
     {
-      SCM threads = all_threads;
+      SCM threads;
+      threads = all_threads;
       scm_i_plugin_cond_broadcast (&wake_up_cond);
-      for (; !SCM_NULLP (threads); threads = SCM_CDR (threads))
-       if (SCM_CAR (threads) != cur_thread)
-         {
-           scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
-           scm_i_plugin_mutex_unlock (&t->heap_mutex);
-         }
+      for (; !scm_is_null (threads); threads = SCM_CDR (threads))
+       {
+         scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads));
+         scm_i_plugin_mutex_unlock (&t->heap_mutex);
+       }
+      scm_i_plugin_mutex_unlock (&thread_admin_mutex);
+      scm_i_enter_guile (SCM_CURRENT_THREAD);
     }
-  SCM_REC_CRITICAL_SECTION_END (gc_section);
 }
 
 void
@@ -1220,13 +1213,13 @@ scm_i_thread_sleep_for_gc ()
   resume (t);
 }
 
-/* The mother of all recursive critical sections */
-scm_t_mutex scm_i_section_mutex;
-
 scm_t_mutex scm_i_critical_section_mutex;
-scm_t_mutex scm_i_defer_mutex;
-int scm_i_defer_count = 0;
-scm_thread *scm_i_defer_owner = 0;
+scm_t_rec_mutex scm_i_defer_mutex;
+
+#if SCM_USE_PTHREAD_THREADS
+# include "libguile/pthread-threads.c"
+#endif
+#include "libguile/threads-plugin.c"
 
 /*** Initialization */
 
@@ -1234,23 +1227,28 @@ void
 scm_threads_prehistory ()
 {
   scm_thread *t;
-  scm_i_plugin_mutex_init (&thread_admin_mutex, 0);
-  scm_i_plugin_mutex_init (&gc_section_mutex, 0);
+#if SCM_USE_PTHREAD_THREADS
+  /* Must be called before any initialization of a mutex. */
+  scm_init_pthread_threads ();
+#endif  
+  scm_i_plugin_mutex_init (&thread_admin_mutex, &scm_i_plugin_mutex);
   scm_i_plugin_cond_init (&wake_up_cond, 0);
-  scm_i_plugin_mutex_init (&scm_i_critical_section_mutex, 0);
+  scm_i_plugin_mutex_init (&scm_i_critical_section_mutex, &scm_i_plugin_mutex);
   thread_count = 1;
   scm_i_plugin_key_create (&scm_i_thread_key, 0);
   scm_i_plugin_key_create (&scm_i_root_state_key, 0);
-  scm_i_plugin_mutex_init (&scm_i_defer_mutex, 0);
-  scm_i_plugin_mutex_init (&scm_i_section_mutex, 0);
+  scm_i_plugin_rec_mutex_init (&scm_i_defer_mutex, &scm_i_plugin_rec_mutex);
   /* Allocate a fake thread object to be used during bootup. */
   t = malloc (sizeof (scm_thread));
   t->base = NULL;
   t->clear_freelists_p = 0;
+  scm_i_plugin_mutex_init (&t->heap_mutex, &scm_i_plugin_mutex);
   scm_setspecific (scm_i_thread_key, t);
+  scm_i_enter_guile (t);
 }
 
 scm_t_bits scm_tc16_thread;
+scm_t_bits scm_tc16_future;
 scm_t_bits scm_tc16_mutex;
 scm_t_bits scm_tc16_fair_mutex;
 scm_t_bits scm_tc16_condvar;
@@ -1292,6 +1290,12 @@ scm_init_threads (SCM_STACKITEM *base)
   threads_initialized_p = 1;
 }
 
+/* scm_i_misc_mutex is intended for miscellaneous uses, to protect
+   operations which are non-reentrant or non-thread-safe but which are
+   either not important enough or not used often enough to deserve their own
+   private mutex.  */
+SCM_GLOBAL_MUTEX (scm_i_misc_mutex);
+
 void
 scm_init_thread_procs ()
 {