guile/libguile/coop-pthreads.c

/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc.
 * 
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */




#include "libguile/_scm.h" /* config.h, _scm.h, __scm.h should be first */

#include <unistd.h>
#include <stdio.h>
#include <assert.h>
#include <sys/time.h>

#include "libguile/validate.h"
#include "libguile/coop-pthreads.h"
#include "libguile/root.h"
#include "libguile/eval.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/gc.h"

#undef DEBUG

/*** Queues */

static SCM
make_queue ()
{
  return scm_cons (SCM_EOL, SCM_EOL);
}

static void
enqueue (SCM q, SCM t)
{
  SCM c = scm_cons (t, SCM_EOL);
  if (scm_is_null (SCM_CAR (q)))
    SCM_SETCAR (q, c);
  else
    SCM_SETCDR (SCM_CDR (q), c);
  SCM_SETCDR (q, c);
}

static SCM
dequeue (SCM q)
{
  SCM c = SCM_CAR (q);
  if (scm_is_null (c))
    return SCM_BOOL_F;
  else
    {
      SCM_SETCAR (q, SCM_CDR (c));
      if (scm_is_null (SCM_CAR (q)))
	SCM_SETCDR (q, SCM_EOL);
      return SCM_CAR (c);
    }
}


/*** Threads */

typedef struct scm_copt_thread {
  
  /* A condition variable for sleeping on.
   */
  pthread_cond_t sleep_cond;

  /* A link for waiting queues.
   */
  struct scm_copt_thread *next_waiting;

  scm_root_state *root;
  SCM handle;
  pthread_t pthread;
  SCM result;

  SCM joining_threads;

  /* For keeping track of the stack and registers. */
  SCM_STACKITEM *base;
  SCM_STACKITEM *top;
  jmp_buf regs;

} scm_copt_thread;

static SCM
make_thread (SCM creation_protects)
{
  SCM z;
  scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread");
  z = scm_cell (scm_tc16_thread, (scm_t_bits)t);
  t->handle = z;
  t->result = creation_protects;
  t->base = NULL;
  t->joining_threads = make_queue ();
  pthread_cond_init (&t->sleep_cond, NULL);
  return z;
}

static void
init_thread_creator (SCM thread, pthread_t th, scm_root_state *r)
{
  scm_copt_thread *t = SCM_THREAD_DATA(thread);
  t->root = r;
  t->pthread = th;
#ifdef DEBUG
  // fprintf (stderr, "%ld created %ld\n", pthread_self (), th);
#endif
}

static void
init_thread_creatant (SCM thread, SCM_STACKITEM *base)
{
  scm_copt_thread *t = SCM_THREAD_DATA(thread);
  t->base = base;
  t->top = NULL;
}

static SCM
thread_mark (SCM obj)
{
  scm_copt_thread *t = SCM_THREAD_DATA (obj);
  scm_gc_mark (t->result);
  scm_gc_mark (t->joining_threads);
  return t->root->handle;
}

static int
thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  scm_copt_thread *t = SCM_THREAD_DATA (exp);
  scm_puts ("#<thread ", port);
  scm_uintprint ((scm_t_bits)t, 16, port);
  if (t->pthread != -1)
    {
      scm_putc (' ', port);
      scm_intprint (t->pthread, 10, port);
    }
  else
    scm_puts (" (exited)", port);
  scm_putc ('>', port);
  return 1;
}

static size_t
thread_free (SCM obj)
{
  scm_copt_thread *t = SCM_THREAD_DATA (obj);
  if (t->pthread != -1)
    abort ();
  scm_gc_free (t, sizeof (*t), "thread");
  return 0;
}

/*** Fair mutexes */

/* POSIX mutexes are not necessarily fair but since we'd like to use a
   mutex for scheduling, we build a fair one on top of POSIX.
*/

typedef struct fair_mutex {
  pthread_mutex_t lock;
  scm_copt_thread *owner;
  scm_copt_thread *next_waiting, *last_waiting;
} fair_mutex;

static void
fair_mutex_init (fair_mutex *m)
{
  pthread_mutex_init (&m->lock, NULL);
  m->owner = NULL;
  m->next_waiting = NULL;
  m->last_waiting = NULL;
}

static void
fair_mutex_lock_1 (fair_mutex *m, scm_copt_thread *t)
{
  if (m->owner == NULL)
    m->owner = t;
  else
    {
      t->next_waiting = NULL;
      if (m->last_waiting)
	m->last_waiting->next_waiting = t;
      else
	m->next_waiting = t;
      m->last_waiting = t;
      do
	{
	  pthread_cond_wait (&t->sleep_cond, &m->lock);
	}
      while (m->owner != t);
      assert (m->next_waiting == t);
      m->next_waiting = t->next_waiting;
      if (m->next_waiting == NULL)
	m->last_waiting = NULL;
    }
  pthread_mutex_unlock (&m->lock);
}

static void
fair_mutex_lock (fair_mutex *m, scm_copt_thread *t)
{
  pthread_mutex_lock (&m->lock);
  fair_mutex_lock_1 (m, t);
}

static void
fair_mutex_unlock_1 (fair_mutex *m)
{
  scm_copt_thread *t;
  pthread_mutex_lock (&m->lock);
  // fprintf (stderr, "%ld unlocking\n", m->owner->pthread);
  if ((t = m->next_waiting) != NULL)
    {
      m->owner = t;
      pthread_cond_signal (&t->sleep_cond);
    }
  else
    m->owner = NULL;
  // fprintf (stderr, "%ld unlocked\n", pthread_self ());
}

static void
fair_mutex_unlock (fair_mutex *m)
{
  fair_mutex_unlock_1 (m);
  pthread_mutex_unlock (&m->lock);
}

/*  Temporarily give up the mutex.  This function makes sure that we
    are on the wait queue before starting the next thread.  Otherwise
    the next thread might preempt us and we will have a hard time
    getting on the wait queue.
*/
#if 0
static void
fair_mutex_yield (fair_mutex *m)
{
  scm_copt_thread *self, *next;

  pthread_mutex_lock (&m->lock);

  /* get next thread
   */
  if ((next = m->next_waiting) == NULL)
    {
      /* No use giving it up. */
      pthread_mutex_unlock (&m->lock);
      return;
    }

  /* put us on queue
   */
  self = m->owner;
  self->next_waiting = NULL;
  if (m->last_waiting)
    m->last_waiting->next_waiting = self;
  else
    m->next_waiting = self;
  m->last_waiting = self;

  /* wake up next thread
   */

  m->owner = next;
  pthread_cond_signal (&next->sleep_cond);

  /* wait for mutex
   */
  do
    {
      pthread_cond_wait (&self->sleep_cond, &m->lock);
    }
  while (m->owner != self);
  assert (m->next_waiting == self);
  m->next_waiting = self->next_waiting;
  if (m->next_waiting == NULL)
    m->last_waiting = NULL;

  pthread_mutex_unlock (&m->lock);
}
#else
static void
fair_mutex_yield (fair_mutex *m)
{
  scm_copt_thread *self = m->owner;
  fair_mutex_unlock_1 (m);
  fair_mutex_lock_1 (m, self);
}
#endif

static void
fair_cond_wait (pthread_cond_t *c, fair_mutex *m)
{
  scm_copt_thread *t = m->owner;
  fair_mutex_unlock_1 (m);
  pthread_cond_wait (c, &m->lock);
  fair_mutex_lock_1 (m, t);
}

/* Return 1 when the mutex was signalled and 0 when not. */
static int
fair_cond_timedwait (pthread_cond_t *c, fair_mutex *m, scm_t_timespec *at)
{
  int res;
  scm_copt_thread *t = m->owner;
  fair_mutex_unlock_1 (m);
  res = pthread_cond_timedwait (c, &m->lock, at);  /* XXX - signals? */
  fair_mutex_lock_1 (m, t);
  return res == 0;
}

/*** Scheduling */

/* When a thread wants to execute Guile functions, it locks the
   guile_mutex.
*/

static fair_mutex guile_mutex;

static SCM cur_thread;
void *scm_i_copt_thread_data;

void
scm_i_copt_set_thread_data (void *data)
{
  scm_copt_thread *t = SCM_THREAD_DATA (cur_thread);
  scm_i_copt_thread_data = data;
  t->root = (scm_root_state *)data;
}
  
static void
resume (scm_copt_thread *t)
{
  cur_thread = t->handle;
  scm_i_copt_thread_data = t->root;
  t->top = NULL;
}

static void
enter_guile (scm_copt_thread *t)
{
  fair_mutex_lock (&guile_mutex, t);
  resume (t);
}

static scm_copt_thread *
suspend ()
{
  SCM cur = cur_thread;
  scm_copt_thread *c = SCM_THREAD_DATA (cur);

  /* record top of stack for the GC */
  c->top = (SCM_STACKITEM *)&c;
  /* save registers. */
  SCM_FLUSH_REGISTER_WINDOWS;
  setjmp (c->regs);

  return c;
}

static scm_copt_thread *
leave_guile ()
{
  scm_copt_thread *c = suspend ();
  fair_mutex_unlock (&guile_mutex);
  return c;
}

int scm_i_switch_counter;

SCM
scm_yield ()
{
  /* Testing guile_mutex.next_waiting without locking guile_mutex.lock
     is OK since the outcome is not critical.  Even when it changes
     after the test, we do the right thing.
  */
  if (guile_mutex.next_waiting)
    {
      scm_copt_thread *t = suspend ();
      fair_mutex_yield (&guile_mutex);
      resume (t);
    }
  return SCM_BOOL_T;
}

/* Put the current thread to sleep until it is explicitely unblocked.
 */
static void
block ()
{
  scm_copt_thread *t = suspend ();
  fair_cond_wait (&t->sleep_cond, &guile_mutex);
  resume (t);
}

/* Put the current thread to sleep until it is explicitely unblocked
   or until a signal arrives or until time AT (absolute time) is
   reached.  Return 1 when it has been unblocked; 0 otherwise.
 */
static int
timed_block (scm_t_timespec *at)
{
  int res;
  scm_copt_thread *t = suspend ();
  res = fair_cond_timedwait (&t->sleep_cond, &guile_mutex, at);
  resume (t);
  return res;
}

/* Unblock a sleeping thread.
 */
static void
unblock (scm_copt_thread *t)
{
  pthread_cond_signal (&t->sleep_cond);
}

/*** Thread creation */

static SCM all_threads;
static int thread_count;

typedef struct launch_data {
  SCM thread;
  SCM rootcont;
  scm_t_catch_body body;
  void *body_data;
  scm_t_catch_handler handler;
  void *handler_data;
} launch_data;

static SCM
body_bootstrip (launch_data* data)
{
  /* First save the new root continuation */
  data->rootcont = scm_root->rootcont;
  return (data->body) (data->body_data);
  // return scm_call_0 (data->body);
}

static SCM
handler_bootstrip (launch_data* data, SCM tag, SCM throw_args)
{
  scm_root->rootcont = data->rootcont;
  return (data->handler) (data->handler_data, tag, throw_args);
  // return scm_apply_1 (data->handler, tag, throw_args);
}

static void
really_launch (SCM_STACKITEM *base, launch_data *data)
{
  SCM thread = data->thread;
  scm_copt_thread *t = SCM_THREAD_DATA (thread);
  init_thread_creatant (thread, base);
  enter_guile (t);

  data->rootcont = SCM_BOOL_F;
  t->result =
    scm_internal_cwdr ((scm_t_catch_body) body_bootstrip,
		       data,
		       (scm_t_catch_handler) handler_bootstrip,
		       data, base);
  free (data);

  pthread_detach (t->pthread);
  all_threads = scm_delq (thread, all_threads);
  t->pthread = -1;
  thread_count--;
  leave_guile ();
}

static void *
launch_thread (void *p)
{
  really_launch ((SCM_STACKITEM *)&p, (launch_data *)p);
  return NULL;
}

static SCM
create_thread (scm_t_catch_body body, void *body_data,
	       scm_t_catch_handler handler, void *handler_data,
	       SCM protects)
{
  SCM thread;

  /* Make new thread.  The first thing the new thread will do is to
     lock guile_mutex.  Thus, we can safely complete its
     initialization after creating it.  While the new thread starts,
     all its data is protected via all_threads.
   */

  {
    pthread_t th;
    SCM root, old_winds;
    launch_data *data;

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

    /* Make thread. */
    thread = make_thread (protects);
    data->thread = thread;
    data->body = body;
    data->body_data = body_data;
    data->handler = handler;
    data->handler_data = handler_data;
    pthread_create (&th, NULL, launch_thread, (void *) data);
    init_thread_creator (thread, th, SCM_ROOT_STATE (root));
    all_threads = scm_cons (thread, all_threads);
    thread_count++;

    /* Return to old dynamic context. */
    scm_dowinds (old_winds, - scm_ilength (old_winds));
  }

  return thread;
}

SCM
scm_call_with_new_thread (SCM argl)
#define FUNC_NAME s_call_with_new_thread
{
  SCM thunk, handler;

  /* Check arguments. */
  {
    register SCM args = argl;
    if (!scm_is_pair (args))
      SCM_WRONG_NUM_ARGS ();
    thunk = SCM_CAR (args);
    SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)),
		thunk,
		SCM_ARG1,
		s_call_with_new_thread);
    args = SCM_CDR (args);
    if (!scm_is_pair (args))
      SCM_WRONG_NUM_ARGS ();
    handler = SCM_CAR (args);
    SCM_ASSERT (scm_is_true (scm_procedure_p (handler)),
		handler,
		SCM_ARG2,
		s_call_with_new_thread);
    if (!scm_is_null (SCM_CDR (args)))
      SCM_WRONG_NUM_ARGS ();
  }

  return create_thread ((scm_t_catch_body) scm_call_0, thunk,
			(scm_t_catch_handler) scm_apply_1, handler,
			argl);
}
#undef FUNC_NAME

SCM
scm_spawn_thread (scm_t_catch_body body, void *body_data,
		  scm_t_catch_handler handler, void *handler_data)
{
  return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F);
}

/*** Mutexes */

/* We implement our own mutex type since we want them to be 'fair', we
   want to do fancy things while waiting for them (like running
   asyncs) and we want to support waiting on many things at once.
   Also, we might add things that are nice for debugging.
*/

typedef struct scm_copt_mutex {
  /* the thread currently owning the mutex, or SCM_BOOL_F. */
  SCM owner;
  /* how much the owner owns us. */
  int level;
  /* the threads waiting for this mutex. */
  SCM waiting;
} scm_copt_mutex;

static SCM
mutex_mark (SCM mx)
{
  scm_copt_mutex *m = SCM_MUTEX_DATA (mx);
  scm_gc_mark (m->owner);
  return m->waiting;
}

SCM
scm_make_mutex ()
{
  SCM mx = scm_make_smob (scm_tc16_mutex);
  scm_copt_mutex *m = SCM_MUTEX_DATA (mx);
  m->owner = SCM_BOOL_F;
  m->level = 0;
  m->waiting = make_queue ();
  return mx;
}

SCM
scm_lock_mutex (SCM mx)
#define FUNC_NAME s_lock_mutex
{
  scm_copt_mutex *m;
  SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
  m = SCM_MUTEX_DATA (mx);

  if (m->owner == SCM_BOOL_F)
    m->owner = cur_thread;
  else if (m->owner == cur_thread)
    m->level++;
  else
    {
      while (m->owner != cur_thread)
	{
	  enqueue (m->waiting, cur_thread);
	  block ();
	  SCM_ASYNC_TICK;
	}
    }
  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM
scm_try_mutex (SCM mx)
#define FUNC_NAME s_try_mutex
{
  scm_copt_mutex *m;
  SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
  m = SCM_MUTEX_DATA (mx);

  if (m->owner == SCM_BOOL_F)
    m->owner = cur_thread;
  else if (m->owner == cur_thread)
    m->level++;
  else
    return SCM_BOOL_F;
  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM
scm_unlock_mutex (SCM mx)
#define FUNC_NAME s_unlock_mutex
{
  scm_copt_mutex *m;
  SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
  m = SCM_MUTEX_DATA (mx);

  if (m->owner != cur_thread)
    {
      if (m->owner == SCM_BOOL_F)
	SCM_MISC_ERROR ("mutex not locked", SCM_EOL);
      else
	SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL);
    }
  else if (m->level > 0)
    m->level--;
  else
    {
      SCM next = dequeue (m->waiting);
      if (scm_is_true (next))
	{
	  m->owner = next;
	  unblock (SCM_THREAD_DATA (next));
	  scm_yield ();
	}
      else
	m->owner = SCM_BOOL_F;
    }
  return SCM_BOOL_T;
}
#undef FUNC_NAME

/*** Condition variables */

/* Like mutexes, we implement our own condition variables using the
   primitives above.
*/

/* yeah, we don't need a structure for this, but more things (like a
   name) will likely follow... */

typedef struct scm_copt_cond {
  /* the threads waiting for this condition. */
  SCM waiting;
} scm_copt_cond;

static SCM
cond_mark (SCM cv)
{
  scm_copt_cond *c = SCM_CONDVAR_DATA (cv);
  return c->waiting;
}

SCM
scm_make_condition_variable (void)
{
  SCM cv = scm_make_smob (scm_tc16_condvar);
  scm_copt_cond *c = SCM_CONDVAR_DATA (cv);
  c->waiting = make_queue ();
  return cv;
}

SCM
scm_timed_wait_condition_variable (SCM cv, SCM mx, SCM t)
#define FUNC_NAME s_wait_condition_variable
{
  scm_copt_cond *c;
  scm_t_timespec waittime;
  int res;

  SCM_ASSERT (SCM_CONDVARP (cv),
	      cv,
	      SCM_ARG1,
	      s_wait_condition_variable);
  SCM_ASSERT (SCM_MUTEXP (mx),
	      mx,
	      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_nsec);
	  waittime.tv_nsec *= 1000;
	}
      else
	{
	  SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec);
	  waittime.tv_nsec = 0;
	}
    }

  c = SCM_CONDVAR_DATA (cv);

  enqueue (c->waiting, cur_thread);
  scm_unlock_mutex (mx);
  if (SCM_UNBNDP (t))
    {
      block ();
      res = 1;
    }
  else
    res = timed_block (&waittime);
  scm_lock_mutex (mx);
  return scm_from_bool (res);
}
#undef FUNC_NAME

SCM
scm_signal_condition_variable (SCM cv)
#define FUNC_NAME s_signal_condition_variable
{
  SCM th;
  scm_copt_cond *c;
  SCM_ASSERT (SCM_CONDVARP (cv),
	      cv,
	      SCM_ARG1,
	      s_signal_condition_variable);
  c = SCM_CONDVAR_DATA (cv);
  if (scm_is_true (th = dequeue (c->waiting)))
    unblock (SCM_THREAD_DATA (th));
  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM
scm_broadcast_condition_variable (SCM cv)
#define FUNC_NAME s_broadcast_condition_variable
{
  SCM th;
  scm_copt_cond *c;
  SCM_ASSERT (SCM_CONDVARP (cv),
	      cv,
	      SCM_ARG1,
	      s_signal_condition_variable);
  c = SCM_CONDVAR_DATA (cv);
  while (scm_is_true (th = dequeue (c->waiting)))
    unblock (SCM_THREAD_DATA (th));
  return SCM_BOOL_T;
}
#undef FUNC_NAME

/*** Initialization */

void
scm_threads_init (SCM_STACKITEM *base)
{
  scm_tc16_thread = scm_make_smob_type ("thread", 0);
  scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_copt_mutex));
  scm_tc16_condvar = scm_make_smob_type ("condition-variable",
					 sizeof (scm_copt_cond));

  scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT;

  fair_mutex_init (&guile_mutex);

  cur_thread = make_thread (SCM_BOOL_F);
  enter_guile (SCM_THREAD_DATA (cur_thread));
  /* root is set later from init.c */
  init_thread_creator (cur_thread, pthread_self(), NULL);
  init_thread_creatant (cur_thread, base);

  thread_count = 1;
  scm_gc_register_root (&all_threads);
  all_threads = scm_cons (cur_thread, SCM_EOL);

  scm_set_smob_mark (scm_tc16_thread, thread_mark);
  scm_set_smob_print (scm_tc16_thread, thread_print);
  scm_set_smob_free (scm_tc16_thread, thread_free);

  scm_set_smob_mark (scm_tc16_mutex, mutex_mark);

  scm_set_smob_mark (scm_tc16_condvar, cond_mark);
}

/*** Marking stacks */

/* XXX - what to do with this?  Do we need to handle this for blocked
   threads as well?
*/
#ifdef __ia64__
# define SCM_MARK_BACKING_STORE() do {                                \
    ucontext_t ctx;                                                   \
    SCM_STACKITEM * top, * bot;                                       \
    getcontext (&ctx);                                                \
    scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext,           \
      ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
       / sizeof (SCM_STACKITEM)));                                    \
    bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base ();  \
    top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx);                   \
    scm_mark_locations (bot, top - bot); } while (0)
#else
# define SCM_MARK_BACKING_STORE()
#endif

void
scm_threads_mark_stacks (void)
{
  volatile SCM c;
  for (c = all_threads; !scm_is_null (c); c = SCM_CDR (c))
    {
      scm_copt_thread *t = SCM_THREAD_DATA (SCM_CAR (c));
      if (t->base == NULL)
	{
	  /* Not fully initialized yet. */
	  continue;
	}
      if (t->top == NULL)
	{
	  /* Active thread */
	  /* stack_len is long rather than sizet in order to guarantee
	     that &stack_len is long aligned */
#if SCM_STACK_GROWS_UP
	  long 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
	  long 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.
	   */
	  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
	}
      else
	{
	  /* Suspended thread */
#if SCM_STACK_GROWS_UP
	  long stack_len = t->top - t->base;
	  scm_mark_locations (t->base, stack_len);
#else
	  long stack_len = t->base - t->top;
	  scm_mark_locations (t->top, stack_len);
#endif
	  scm_mark_locations ((SCM_STACKITEM *) t->regs,
			      ((size_t) sizeof(t->regs)
			       / sizeof (SCM_STACKITEM)));
	}
    }
}

/*** Select */

int
scm_internal_select (int nfds,
		     SELECT_TYPE *readfds,
		     SELECT_TYPE *writefds,
		     SELECT_TYPE *exceptfds,
		     struct timeval *timeout)
{
  int res, eno;
  scm_copt_thread *c = leave_guile ();
  res = select (nfds, readfds, writefds, exceptfds, timeout);
  eno = errno;
  enter_guile (c);
  SCM_ASYNC_TICK;
  errno = eno;
  return res;
}

void
scm_init_iselect ()
{
}

unsigned long
scm_thread_usleep (unsigned long usec)
{
  scm_copt_thread *c = leave_guile ();
  usleep (usec);
  enter_guile (c);
  return 0;
}

unsigned long
scm_thread_sleep (unsigned long sec)
{
  unsigned long res;
  scm_copt_thread *c = leave_guile ();
  res = sleep (sec);
  enter_guile (c);
  return res;
}

/*** Misc */

SCM
scm_current_thread (void)
{
  return cur_thread;
}

SCM
scm_all_threads (void)
{
  return all_threads;
}

scm_root_state *
scm_i_thread_root (SCM thread)
{
  if (thread == cur_thread)
    return scm_i_copt_thread_data;
  else
    return ((scm_copt_thread *)SCM_THREAD_DATA (thread))->root;
}

SCM
scm_join_thread (SCM thread)
#define FUNC_NAME s_join_thread
{
  scm_copt_thread *t;
  SCM res;

  SCM_VALIDATE_THREAD (1, thread);

  t = SCM_THREAD_DATA (thread);
  if (t->pthread != -1)
    {
      scm_copt_thread *c = leave_guile ();
      pthread_join (t->pthread, NULL);
      enter_guile (c);
    }
  res = t->result;
  t->result = SCM_BOOL_F;
  return res;
}
#undef FUNC_NAME

int
scm_c_thread_exited_p (SCM thread)
#define FUNC_NAME s_scm_thread_exited_p
{
  scm_copt_thread *t;
  SCM_VALIDATE_THREAD (1, thread);
  t = SCM_THREAD_DATA (thread);
  return t->pthread == -1;
}
#undef FUNC_NAME

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/