guile/libguile/coop-threads.c.cygnus

/*	Copyright (C) 1995, 1996 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, 675 Mass Ave, Cambridge, MA 02139, 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 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.
 *
 * 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.  
 */


/* A counter of the current number of threads */
size_t scm_thread_count = 0;

/* This is included rather than compiled seperately in order
   to simplify the configuration mechanism. */
#include "coop.c"

/* A count-down counter used to determine when to switch
   contexts */
size_t scm_switch_counter = SCM_THREAD_SWITCH_COUNT;

coop_m scm_critical_section_mutex;

static struct gscm_type scm_thread_type;
static struct gscm_type scm_mutex_type;
static struct gscm_type scm_condition_variable_type;

/* This mutex is used to synchronize thread creation */
static coop_m scm_coop_create_mutex;

/* Support structure for thread creation */
struct scm_coop_create_info_type scm_coop_create_info;

#ifdef __STDC__
int
gscm_threads_thread_equal (SCM t1, SCM t2)
#else
int
gscm_threads_thread_equal (t1, t2)
     SCM t1, t2;
#endif
{
  return (*(coop_t **) gscm_unwrap_obj (&scm_thread_type, &t1) ==
	  *(coop_t **) gscm_unwrap_obj (&scm_thread_type, &t2));
}

#ifdef __STDC__
void
gscm_threads_thread_die (SCM t)
#else
void
gscm_threads_thread_die (t)
     SCM t;
#endif
{
  coop_t **thread = (coop_t **) gscm_unwrap_obj (&scm_thread_type, &t);
  free(*thread);
}

#ifdef __STDC__
void
gscm_threads_mutex_die (SCM m)
#else
void
gscm_threads_scm_mutex_die (m)
     SCM m;
#endif
{
  /* He's dead, Jim */
}

#ifdef __STDC__
void
gscm_threads_condition_variable_die (SCM c)
#else
void
gscm_threads_condition_variable_die (c)
     SCM c;
#endif
{
  /* He's dead, Jim */
}

#ifdef __STDC__
void
gscm_threads_init ()
#else
void
gscm_threads_init ()
#endif
{
}

/* cleanup for info structure
 */
#ifdef __STDC__
static void
scm_pthread_delete_info (void *ptr)
#else
static void
scm_pthread_delete_info (ptr)
     void *ptr;
#endif
{
}

#ifdef __STDC__
void
gscm_threads_init_coop_threads ()
#else
void
gscm_threads_init_coop_threads ()
#endif
{
  SCM *prots;

  coop_init();

  scm_thread_count = 1;

  prots = (SCM *)malloc (sizeof (SCM) * scm_num_thread_local_protects);

  coop_global_main.sto = &prots;
  coop_global_main.base = &prots;
  coop_global_curr = &coop_global_main;
  coop_all_qput (&coop_global_allq, coop_global_curr);

  coop_mutex_init(&scm_coop_create_mutex);
  coop_mutex_init(&scm_critical_section_mutex);

  coop_global_main.data = prots;

  /* Initialize the root thread specific data pointer. All new threads
     get a copy of this buffer. 
  scm_root_prots = prots; */
}

#ifdef __STDC__
void
gscm_threads_mark_stacks ()
#else
void
gscm_threads_mark_stacks ()
#endif
{
  coop_t *thread;
  int j;
  jmp_buf scm_save_regs_gc_mark;
  
  for (thread = coop_global_allq.t.all_next; 
       thread != NULL; thread = thread->all_next)
    {
      if (thread == coop_global_curr)
	{
	  /* Active thread */
	  /* stack_len is long rather than sizet in order to guarantee
	     that &stack_len is long aligned */
#ifdef STACK_GROWS_UP
	  long stack_len = (STACKITEM *) (&thread) -
	    (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 values from LENGTH and CHARS must remain
	   * usable.   This requirement is stricter than a liveness
	   * requirement -- in particular, it constrains the implementation
	   * of scm_resizuve.
	   */
	  FLUSH_REGISTER_WINDOWS;
	  /* This assumes that all registers are saved into the jmp_buf */
	  setjmp (scm_save_regs_gc_mark);
	  scm_mark_locations ((STACKITEM *) scm_save_regs_gc_mark,
			      ((sizet) sizeof scm_save_regs_gc_mark
			       / sizeof (STACKITEM)), BOOL_T);
	  
	  scm_mark_locations (((size_t) thread->base,
			       (sizet) stack_len, BOOL_T));
#else
	  long stack_len = (STACKITEM *) thread->base -
	    (STACKITEM *) (&thread);
	  
	  /* 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 values from LENGTH and CHARS must remain
	   * usable.   This requirement is stricter than a liveness
	   * requirement -- in particular, it constrains the implementation
	   * of scm_resizuve.
	   */
	  FLUSH_REGISTER_WINDOWS;
	  /* This assumes that all registers are saved into the jmp_buf */
	  setjmp (scm_save_regs_gc_mark);
	  scm_mark_locations ((STACKITEM *) scm_save_regs_gc_mark,
			      ((sizet) sizeof scm_save_regs_gc_mark
			       / sizeof (STACKITEM)), BOOL_T);
	  
	  scm_mark_locations ((STACKITEM *) &thread,
			      stack_len, BOOL_T);
#endif
	}
      else
	{
	  /* Suspended thread */
#ifdef STACK_GROWS_UP
	  long stack_len = (STACKITEM *) (thread->sp) -
	    (STACKITEM *) thread->base;

	  scm_mark_locations (((size_t)thread->base,
			       (sizet) stack_len, BOOL_T));
#else
	  long stack_len = (STACKITEM *) thread->base -
	    (STACKITEM *) (thread->sp);
	  
	  /* Registers are already on the stack. No need to mark. */
	  
	  scm_mark_locations ((STACKITEM *) (size_t)thread->sp,
			      stack_len, BOOL_T);
#endif
	}

      /* Mark all the of this thread's thread-local protects */
      for (j = scm_num_thread_local_protects-1; j >= 0; j--)
	{
	  scm_gc_mark (((SCM*)(thread->data))[j], BOOL_F);
	}
    }
}

#ifdef __STDC__
void
launch_thread (void *p)
#else
void
launch_thread (p)
     void *p;
#endif
{
  SCM thunk = scm_coop_create_info.thunk;
  SCM error = scm_coop_create_info.error;

  /* dynwinds must be set to BOOL_F for each new thread
     (it is a thread-local variable) */
  dynwinds = BOOL_F;

  coop_mutex_unlock(&scm_coop_create_mutex);

  scm_with_dynamic_root (thunk, error);

  scm_thread_count--;
}

#ifdef __STDC__
SCM
gscm_threads_with_new_thread (SCM thunk, SCM error_thunk)
#else
SCM
gscm_threads_with_new_thread (thunk, error_thunk)
     SCM thunk;
     SCM error_thunk;
#endif
{
  int rc;
  SCM t = gscm_alloc (&scm_thread_type, sizeof(coop_t *));

  coop_t **pt = (coop_t **) gscm_unwrap_obj (&scm_thread_type, &t);

  int status;

  /* Rather than allocate space to hold fn and arg, a mutex is used
     to serialize thread creation. */
  coop_mutex_lock(&scm_coop_create_mutex); 
  
  /* this data is passed to the newly created thread */
  scm_coop_create_info.thunk = thunk;
  scm_coop_create_info.error = error_thunk;
  
  *pt = coop_create(launch_thread, &scm_coop_create_info);
  scm_thread_count++;

  {
    SCM * prots;

    prots = (SCM *)malloc (sizeof (SCM) * scm_num_thread_local_protects);

    (*pt)->data = prots;

    /* Copy root thread specific data over */
    memcpy(prots, (SCM*)coop_global_curr->data,
	   sizeof (SCM) * scm_num_thread_local_protects);

    prots[SCM_THREAD_T] = t;
    prots[SCM_THREAD_THUNK] = thunk;
    prots[SCM_THREAD_ERROR] = error_thunk;
  }

  /* we're now ready for the thread to begin */
  coop_yield();

  return t;
}

#ifdef __STDC__
SCM
gscm_threads_join_thread (SCM t)
#else
SCM
gscm_threads_join_thread (t)
     SCM t;
#endif
{
  coop_t **thread = (coop_t **) gscm_unwrap_obj (&scm_thread_type, &t);

  coop_join(*thread);

  return SCM_BOOL_T;
}

#ifdef __STDC__
SCM
gscm_threads_make_mutex ()
#else
SCM
gscm_threads_make_mutex ()
#endif
{
  SCM t = gscm_alloc (&scm_mutex_type, sizeof(coop_m));

  coop_m *m = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &t);

  coop_mutex_init(m);

  return t;
}

#ifdef __STDC__
SCM
gscm_threads_lock_mutex (SCM m)
#else
SCM
gscm_threads_lock_mutex (m)
     SCM m;
#endif
{
  coop_m *mutex = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &m);

  coop_mutex_lock(mutex);

  return SCM_BOOL_T;
}

#ifdef __STDC__
SCM
gscm_threads_unlock_mutex (SCM m)
#else
SCM
gscm_threads_unlock_mutex (m)
     SCM m;
#endif
{
  coop_m *mutex = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &m);

  coop_mutex_unlock(mutex);

  /* Yield early */
  scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
  coop_yield();

  return SCM_BOOL_T;
}

#ifdef __STDC__
SCM
gscm_threads_make_condition_variable ()
#else
SCM
gscm_threads_make_condition_variable ()
#endif
{
  SCM t = gscm_alloc (&scm_mutex_type, sizeof(coop_c));

  coop_c *c = (coop_c *) gscm_unwrap_obj (&scm_condition_variable_type, &t);

  coop_condition_variable_init(c);

  return t;
}

#ifdef __STDC__
SCM
gscm_threads_condition_variable_wait (SCM c, SCM m)
#else
SCM
gscm_threads_condition_variable_wait (c, m)
     SCM c;
     SCM m;
#endif
{
  coop_c *cv    = (coop_c *) gscm_unwrap_obj (&scm_condition_variable_type, &c);
  coop_m *mutex = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &m);

  coop_mutex_unlock(mutex);
  coop_condition_variable_wait(cv);

  return SCM_BOOL_T;
}

#ifdef __STDC__
SCM
gscm_threads_condition_variable_signal (SCM c)
#else
SCM
gscm_threads_condition_variable_signal (c)
     SCM c;
#endif
{
  coop_c *cv    = (coop_c *) gscm_unwrap_obj (&scm_condition_variable_type, &c);

  coop_condition_variable_signal(cv);

  return SCM_BOOL_T;
}

#ifdef __STDC__
SCM
gscm_threads_yield ()
#else
SCM
gscm_threads_yield ()
#endif
{
  /* Yield early */
  scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
  coop_yield();

  return SCM_BOOL_T;
}