[bpt/guile.git] / libguile / mit-pthreads.c

/*	Copyright (C) 1995, 1996, 1997 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 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.  */
\f

typedef struct scm_pthread_info {
  queue q;		     /* the dequeue on which this structure exists */
  			     /* reqired to be the first element */
  pthread_t thread;	     /* the corresponding thread structure */
  void *stack_top;	     /* the highest address in this thread's stack */
  scm_root_state *root;      /* root for this thread */
} scm_pthread_info;

pthread_mutex_t scm_critical_section_mutex;
pthread_t scm_critical_section_owner;

static queue infos = { &infos, &infos };  /* the dequeue of info structures */

/* Key to thread specific data */
pthread_key_t info_key;

#ifdef __STDC__
size_t
scm_threads_free_thread (SCM t)
#else
size_t
scm_threads_free_thread (t)
     SCM t;
#endif
{
  scm_must_free (SCM_THREAD_DATA (t));
  return sizeof (pthread_t);
}

#ifdef __STDC__
size_t
scm_threads_free_mutex (SCM m)
#else
size_t
scm_threads_free_mutex (m)
     SCM m;
#endif
{
  pthread_mutex_destroy (SCM_MUTEX_DATA (m));
  scm_must_free (SCM_MUTEX_DATA (m));
  return sizeof (pthread_mutex_t);
}

#ifdef __STDC__
size_t
scm_threads_free_condvar (SCM c)
#else
size_t
scm_threads_free_condvar (c)
     SCM c;
#endif
{
  pthread_cond_destroy (SCM_CONDVAR_DATA (c));
  scm_must_free (SCM_CONDVAR_DATA (c));
  return sizeof (pthread_cond_t);
}

/* 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
{
  scm_pthread_info *info = (scm_pthread_info *) ptr;
  info->q.blink->flink = info->q.flink;
  info->q.flink->blink = info->q.blink;
  scm_must_free ((char *) info);
}

#ifdef __STDC__
void
scm_threads_init (SCM_STACKITEM *i)
#else
void
scm_threads_init (i)
     SCM_STACKITEM *i;
#endif
{
  /*
   * each info structure is made thread-specific, so that the cleanup
   * mechanism can be used to reclaim the space in a timely fashion.
   */
  pthread_key_create (&info_key, scm_pthread_delete_info);

  /* initialize various mutex variables */
  pthread_mutex_init (&scm_critical_section_mutex, NULL);

  /*
   * create an info structure for the initial thread and push it onto
   * the info dequeue
   */
  {
    scm_pthread_info *info;
    info = (scm_pthread_info *) scm_must_malloc (sizeof (scm_pthread_info),
						 "threads_init");
    infos.flink = infos.blink = &info->q;
    info->q.flink = info->q.blink = &infos;
    info->thread = pthread_initial;
    info->stack_top = (void *) i;
    pthread_setspecific(info_key, info);
  }
  /* The root state pointer gets initialized in init.c. */
}

/* given some thread, find the corresponding info
 */
static scm_pthread_info *pthreads_find_info (pthread_t target)
{
  queue *ptr = infos.flink;

  while (ptr != &infos)
    {
      scm_pthread_info *info = (scm_pthread_info *) ptr;

      if (info->thread == target)
        {
          return (info);
        }
      ptr = ptr->flink;
    }
}

#ifdef __STDC__
void
scm_threads_mark_stacks ()
#else
void
scm_threads_mark_stacks ()
#endif
{
  scm_pthread_info *info;
  pthread_t thread;
  int j;
  
  for (info = (scm_pthread_info *) infos.flink;
       info != (scm_pthread_info *) &infos;
       info = (scm_pthread_info *) info->q.flink)
    {
      thread = info->thread;
      if (thread == pthread_run)
	{
	  /* 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 = ((SCM_STACKITEM *) (&thread) -
			    (SCM_STACKITEM *) info->stack_top);
	  
	  /* 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 SCM_LENGTH and SCM_CHARS 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,
			      ((scm_sizet) sizeof scm_save_regs_gc_mark
			       / sizeof (SCM_STACKITEM)));
	  
	  scm_mark_locations (((size_t) info->stack_top,
			       (sizet) stack_len));
#else
	  long stack_len = ((SCM_STACKITEM *) info->stack_top -
			    (SCM_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 SCM_LENGTH and SCM_CHARS 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,
			      ((scm_sizet) sizeof scm_save_regs_gc_mark
			       / sizeof (SCM_STACKITEM)));
	  
	  scm_mark_locations ((SCM_STACKITEM *) &thread,
			      stack_len);
#endif
	}
      else
	{
	  /* Suspended thread */
#ifdef STACK_GROWS_UP
	  long stack_len = ((SCM_STACKITEM *) (thread->THREAD_SP) -
			    (SCM_STACKITEM *) info->stack_top);
	      
	  scm_mark_locations ((size_t)info->stack_top,
			      (sizet) stack_len);
#else
	  long stack_len = ((SCM_STACKITEM *) info->stack_top -
			    (SCM_STACKITEM *) (thread->THREAD_SP));
	      
	  scm_mark_locations ((SCM_STACKITEM *) thread->machdep_data.machdep_state,
			      ((scm_sizet) sizeof (*thread->machdep_data.machdep_state)
			       / sizeof (SCM_STACKITEM)));
	  scm_mark_locations ((SCM_STACKITEM *) (size_t) thread->THREAD_SP,
			      stack_len);
#endif
	}

      /* Mark this thread's root */
      scm_gc_mark (((scm_root_state *) info->root) -> handle);
    }
}

#ifdef __STDC__
void *
launch_thread (void *p)
#else
void *
launch_thread (p)
     void *p;
#endif
{
  /* The thread object will be GC protected by being a member of the
     list given as argument to launch_thread.  It will be marked
     during the conservative sweep of the stack. */
  SCM args = (SCM) p;
  pthread_attr_setcleanup (&pthread_self () -> attr,
			   NULL,
			   SCM_ROOT_STATE (SCM_CAR (args)));
  scm_call_with_dynamic_root (SCM_CADDR (args), SCM_CADDDR (args));
  return NULL;
}

#ifdef __STDC__
SCM
scm_call_with_new_thread (SCM argl)
#else
SCM
scm_call_with_new_thread (argl)
     SCM argl;
#endif
{
  SCM thread;

  /* Check arguments. */
  {
    register SCM args = argl;
    SCM thunk, handler;
    SCM_ASSERT (SCM_NIMP (args),
		scm_makfrom0str (s_call_with_new_thread),
		SCM_WNA, NULL);
    thunk = SCM_CAR (args);
    SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)),
		thunk,
		SCM_ARG1,
		s_call_with_new_thread);
    args = SCM_CDR (args);
    SCM_ASSERT (SCM_NIMP (args),
		scm_makfrom0str (s_call_with_new_thread),
		SCM_WNA, NULL);
    handler = SCM_CAR (args);
    SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)),
		handler,
		SCM_ARG2,
		s_call_with_new_thread);
    SCM_ASSERT (SCM_NULLP (SCM_CDR (args)),
		scm_makfrom0str (s_call_with_new_thread),
		SCM_WNA, NULL);
  }

  /* Make new thread. */
  {
    pthread_attr_t attr;
    pthread_t t;
    scm_pthread_info *info = 
      (scm_pthread_info *) scm_must_malloc (sizeof (scm_pthread_info),
					    "pthread_info");
    SCM root, old_winds;

    /* 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);
    /* Make thread. */
    SCM_NEWCELL (thread);
    SCM_DEFER_INTS;
    SCM_SETCAR (thread, scm_tc16_thread);
    argl = scm_cons2 (root, thread, argl);
  
    /* thread mustn't start until we've built the info struct */
    pthread_kernel_lock++;

    /* initialize and create the thread. */
    pthread_attr_init (&attr);
    pthread_attr_setschedpolicy (&attr, SCHED_RR);
  
    pthread_create (&t, &attr, launch_thread, (void *) argl);
    pthread_attr_destroy (&attr);

    /* push the info onto the dequeue */
    info->q.flink = infos.flink;
    info->q.blink = &infos;
    infos.flink->blink = &info->q;
    infos.flink = &info->q;
    /* pthread_create filled in the initial SP -- profitons-en ! */
    info->stack_top = (void *) (t->THREAD_SP);
    info->thread = t;
    info->root = SCM_ROOT_STATE (root);
    SCM_SETCDR (thread, t);
    SCM_ALLOW_INTS;
    
    /* we're now ready for the thread to begin */
    pthread_kernel_lock--;

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

  return thread;
}

#ifdef __STDC__
SCM
scm_join_thread (SCM t)
#else
SCM
scm_join_thread (t)
     SCM t;
#endif
{
  void *value;
  pthread_join (SCM_THREAD_DATA (t), &value);
  return SCM_BOOL_T;
}

#ifdef __STDC__
SCM
scm_yield ()
#else
SCM
scm_yield ()
#endif
{
  pthread_yield ();
  return SCM_BOOL_T;
}

#ifdef __STDC__
SCM
scm_make_mutex ()
#else
SCM
scm_make_mutex ()
#endif
{
  SCM m;
  pthread_mutex_t *data = (pthread_mutex_t *) scm_must_malloc (sizeof (pthread_mutex_t), "mutex");
  SCM_NEWSMOB (m,scm_tc16_mutex, data);
  pthread_mutex_init (SCM_MUTEX_DATA (m), NULL);
  return m;
}

#ifdef __STDC__
SCM
scm_lock_mutex (SCM m)
#else
SCM
scm_lock_mutex (m)
     SCM m;
#endif
{
  SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);
  pthread_mutex_lock (SCM_MUTEX_DATA (m));
  return SCM_BOOL_T;
}

#ifdef __STDC__
SCM
scm_unlock_mutex (SCM m)
#else
SCM
scm_unlock_mutex (m)
     SCM m;
#endif
{
  SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_unlock_mutex);
  pthread_mutex_unlock (SCM_MUTEX_DATA (m));
  return SCM_BOOL_T;
}

#ifdef __STDC__
SCM
scm_make_condition_variable ()
#else
SCM
scm_make_condition_variable ()
#endif
{
  SCM c;
  pthread_cond_t *data = (pthread_cond_t *) scm_must_malloc (sizeof (pthread_cond_t), "condvar");
  SCM_NEWSMOB (c, scm_tc16_condvar, data);
  pthread_cond_init (SCM_CONDVAR_DATA (c), NULL);
  return c;
}

#ifdef __STDC__
SCM
scm_wait_condition_variable (SCM c, SCM m)
#else
SCM
scm_wait_condition_variable (c, m)
     SCM c;
     SCM m;
#endif
{
  SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c),
	      c,
	      SCM_ARG1,
	      s_wait_condition_variable);
  SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m),
	      m,
	      SCM_ARG2,
	      s_wait_condition_variable);
  pthread_cond_wait (SCM_CONDVAR_DATA (m), SCM_MUTEX_DATA (c));
  return SCM_BOOL_T;
}

#ifdef __STDC__
SCM
scm_signal_condition_variable (SCM c)
#else
SCM
scm_signal_condition_variable (c)
     SCM c;
#endif
{
  SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c),
	      c,
	      SCM_ARG1,
	      s_signal_condition_variable);
  pthread_cond_signal (SCM_CONDVAR_DATA (c));
  return SCM_BOOL_T;
}
Commit	Line	Data
7dc6e754	1	/* Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
7bfd3b9e JB	2	*
	3	* This program is free software; you can redistribute it and/or modify
	4	* it under the terms of the GNU General Public License as published by
	5	* the Free Software Foundation; either version 2, or (at your option)
	6	* any later version.
	7	*
	8	* This program is distributed in the hope that it will be useful,
	9	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	11	* GNU General Public License for more details.
	12	*
	13	* You should have received a copy of the GNU General Public License
	14	* along with this software; see the file COPYING. If not, write to
82892bed JB	15	* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
82892bed JB	16	* Boston, MA 02111-1307 USA
7bfd3b9e JB	17	*
	18	* As a special exception, the Free Software Foundation gives permission
	19	* for additional uses of the text contained in its release of GUILE.
	20	*
	21	* The exception is that, if you link the GUILE library with other files
	22	* to produce an executable, this does not by itself cause the
	23	* resulting executable to be covered by the GNU General Public License.
	24	* Your use of that executable is in no way restricted on account of
	25	* linking the GUILE library code into it.
	26	*
	27	* This exception does not however invalidate any other reasons why
	28	* the executable file might be covered by the GNU General Public License.
	29	*
	30	* This exception applies only to the code released by the
	31	* Free Software Foundation under the name GUILE. If you copy
	32	* code from other Free Software Foundation releases into a copy of
	33	* GUILE, as the General Public License permits, the exception does
	34	* not apply to the code that you add in this way. To avoid misleading
	35	* anyone as to the status of such modified files, you must delete
	36	* this exception notice from them.
	37	*
	38	* If you write modifications of your own for GUILE, it is your choice
	39	* whether to permit this exception to apply to your modifications.
82892bed	40	* If you do not wish that, delete this exception notice. */
7bfd3b9e JB	41	\f
	42
	43	typedef struct scm_pthread_info {
	44	queue q; /* the dequeue on which this structure exists */
	45	/* reqired to be the first element */
	46	pthread_t thread; /* the corresponding thread structure */
	47	void stack_top; / the highest address in this thread's stack */
	48	scm_root_state root; / root for this thread */
	49	} scm_pthread_info;
	50
	51	pthread_mutex_t scm_critical_section_mutex;
	52	pthread_t scm_critical_section_owner;
	53
	54	static queue infos = { &infos, &infos }; /* the dequeue of info structures */
	55
	56	/* Key to thread specific data */
	57	pthread_key_t info_key;
	58
	59	#ifdef __STDC__
	60	size_t
	61	scm_threads_free_thread (SCM t)
	62	#else
	63	size_t
	64	scm_threads_free_thread (t)
	65	SCM t;
	66	#endif
	67	{
	68	scm_must_free (SCM_THREAD_DATA (t));
	69	return sizeof (pthread_t);
	70	}
	71
	72	#ifdef __STDC__
	73	size_t
	74	scm_threads_free_mutex (SCM m)
	75	#else
	76	size_t
	77	scm_threads_free_mutex (m)
	78	SCM m;
	79	#endif
	80	{
	81	pthread_mutex_destroy (SCM_MUTEX_DATA (m));
	82	scm_must_free (SCM_MUTEX_DATA (m));
	83	return sizeof (pthread_mutex_t);
	84	}
	85
	86	#ifdef __STDC__
	87	size_t
	88	scm_threads_free_condvar (SCM c)
	89	#else
	90	size_t
	91	scm_threads_free_condvar (c)
	92	SCM c;
	93	#endif
	94	{
	95	pthread_cond_destroy (SCM_CONDVAR_DATA (c));
	96	scm_must_free (SCM_CONDVAR_DATA (c));
	97	return sizeof (pthread_cond_t);
	98	}
	99
	100	/* cleanup for info structure
	101	*/
	102	#ifdef __STDC__
	103	static void
	104	scm_pthread_delete_info (void *ptr)
105	#else
106	static void
107	scm_pthread_delete_info (ptr)
108	void *ptr;
109	#endif
110	{
111	scm_pthread_info info = (scm_pthread_info ) ptr;
112	info->q.blink->flink = info->q.flink;
113	info->q.flink->blink = info->q.blink;
114	scm_must_free ((char *) info);
115	}
116
117	#ifdef __STDC__
118	void
119	scm_threads_init (SCM_STACKITEM *i)
120	#else
121	void
122	scm_threads_init (i)
123	SCM_STACKITEM *i;
124	#endif
125	{
126	/*
127	* each info structure is made thread-specific, so that the cleanup
128	* mechanism can be used to reclaim the space in a timely fashion.
129	*/
130	pthread_key_create (&info_key, scm_pthread_delete_info);
131
132	/* initialize various mutex variables */
133	pthread_mutex_init (&scm_critical_section_mutex, NULL);
134
135	/*
136	* create an info structure for the initial thread and push it onto
137	* the info dequeue
138	*/
139	{
140	scm_pthread_info *info;
141	info = (scm_pthread_info *) scm_must_malloc (sizeof (scm_pthread_info),
142	"threads_init");
143	infos.flink = infos.blink = &info->q;
144	info->q.flink = info->q.blink = &infos;
145	info->thread = pthread_initial;
146	info->stack_top = (void *) i;
147	pthread_setspecific(info_key, info);
148	}
149	/* The root state pointer gets initialized in init.c. */
150	}
151
152	/* given some thread, find the corresponding info
153	*/
154	static scm_pthread_info *pthreads_find_info (pthread_t target)
155	{
156	queue *ptr = infos.flink;
157
158	while (ptr != &infos)
159	{
160	scm_pthread_info info = (scm_pthread_info ) ptr;
161
162	if (info->thread == target)
163	{
164	return (info);
165	}
166	ptr = ptr->flink;
167	}
168	}
169
170	#ifdef __STDC__
171	void
172	scm_threads_mark_stacks ()
173	#else
174	void
175	scm_threads_mark_stacks ()
176	#endif
177	{
178	scm_pthread_info *info;
179	pthread_t thread;
180	int j;
181
182	for (info = (scm_pthread_info *) infos.flink;
183	info != (scm_pthread_info *) &infos;
184	info = (scm_pthread_info *) info->q.flink)
185	{
186	thread = info->thread;
187	if (thread == pthread_run)
188	{
189	/* Active thread */
190	/* stack_len is long rather than sizet in order to guarantee
191	that &stack_len is long aligned */
192	#ifdef STACK_GROWS_UP
193	long stack_len = ((SCM_STACKITEM *) (&thread) -
194	(SCM_STACKITEM *) info->stack_top);
195
196	/* Protect from the C stack. This must be the first marking
197	* done because it provides information about what objects
198	* are "in-use" by the C code. "in-use" objects are those
199	* for which the values from SCM_LENGTH and SCM_CHARS must remain
200	* usable. This requirement is stricter than a liveness
201	* requirement -- in particular, it constrains the implementation
202	* of scm_resizuve.
203	*/
204	SCM_FLUSH_REGISTER_WINDOWS;
205	/* This assumes that all registers are saved into the jmp_buf */
206	setjmp (scm_save_regs_gc_mark);
207	scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
208	((scm_sizet) sizeof scm_save_regs_gc_mark
209	/ sizeof (SCM_STACKITEM)));
210
211	scm_mark_locations (((size_t) info->stack_top,
212	(sizet) stack_len));
213	#else
214	long stack_len = ((SCM_STACKITEM *) info->stack_top -
215	(SCM_STACKITEM *) (&thread));
216
217	/* Protect from the C stack. This must be the first marking
218	* done because it provides information about what objects
219	* are "in-use" by the C code. "in-use" objects are those
220	* for which the values from SCM_LENGTH and SCM_CHARS must remain
221	* usable. This requirement is stricter than a liveness
222	* requirement -- in particular, it constrains the implementation
223	* of scm_resizuve.
224	*/
225	SCM_FLUSH_REGISTER_WINDOWS;
226	/* This assumes that all registers are saved into the jmp_buf */
227	setjmp (scm_save_regs_gc_mark);
228	scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
229	((scm_sizet) sizeof scm_save_regs_gc_mark
230	/ sizeof (SCM_STACKITEM)));
231
232	scm_mark_locations ((SCM_STACKITEM *) &thread,
233	stack_len);
234	#endif
235	}
236	else
237	{
238	/* Suspended thread */
239	#ifdef STACK_GROWS_UP
240	long stack_len = ((SCM_STACKITEM *) (thread->THREAD_SP) -
241	(SCM_STACKITEM *) info->stack_top);
242
243	scm_mark_locations ((size_t)info->stack_top,
244	(sizet) stack_len);
245	#else
246	long stack_len = ((SCM_STACKITEM *) info->stack_top -
247	(SCM_STACKITEM *) (thread->THREAD_SP));
248
249	scm_mark_locations ((SCM_STACKITEM *) thread->machdep_data.machdep_state,
250	((scm_sizet) sizeof (*thread->machdep_data.machdep_state)
251	/ sizeof (SCM_STACKITEM)));
252	scm_mark_locations ((SCM_STACKITEM *) (size_t) thread->THREAD_SP,
253	stack_len);
254	#endif
255	}
256
257	/* Mark this thread's root */
258	scm_gc_mark (((scm_root_state *) info->root) -> handle);
259	}
260	}
261
262	#ifdef __STDC__
263	void *
264	launch_thread (void *p)
265	#else
266	void *
267	launch_thread (p)
268	void *p;
269	#endif
270	{
271	/* The thread object will be GC protected by being a member of the
272	list given as argument to launch_thread. It will be marked
273	during the conservative sweep of the stack. */
274	SCM args = (SCM) p;
275	pthread_attr_setcleanup (&pthread_self () -> attr,
276	NULL,
277	SCM_ROOT_STATE (SCM_CAR (args)));
278	scm_call_with_dynamic_root (SCM_CADDR (args), SCM_CADDDR (args));
279	return NULL;
280	}
281
282	#ifdef __STDC__
283	SCM
284	scm_call_with_new_thread (SCM argl)
285	#else
286	SCM
287	scm_call_with_new_thread (argl)
288	SCM argl;
289	#endif
290	{
291	SCM thread;
292
293	/* Check arguments. */
294	{
295	register SCM args = argl;
296	SCM thunk, handler;
0824b524 MD	297	SCM_ASSERT (SCM_NIMP (args),
	298	scm_makfrom0str (s_call_with_new_thread),
	299	SCM_WNA, NULL);
7bfd3b9e JB	300	thunk = SCM_CAR (args);
	301	SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)),
	302	thunk,
	303	SCM_ARG1,
	304	s_call_with_new_thread);
	305	args = SCM_CDR (args);
0824b524 MD	306	SCM_ASSERT (SCM_NIMP (args),
	307	scm_makfrom0str (s_call_with_new_thread),
	308	SCM_WNA, NULL);
7bfd3b9e JB	309	handler = SCM_CAR (args);
	310	SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)),
	311	handler,
	312	SCM_ARG2,
	313	s_call_with_new_thread);
0824b524 MD	314	SCM_ASSERT (SCM_NULLP (SCM_CDR (args)),
	315	scm_makfrom0str (s_call_with_new_thread),
	316	SCM_WNA, NULL);
7bfd3b9e JB	317	}
	318
	319	/* Make new thread. */
	320	{
	321	pthread_attr_t attr;
	322	pthread_t t;
	323	scm_pthread_info *info =
	324	(scm_pthread_info *) scm_must_malloc (sizeof (scm_pthread_info),
	325	"pthread_info");
	326	SCM root, old_winds;
	327
	328	/* Unwind wind chain. */
	329	old_winds = scm_dynwinds;
	330	scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
	331
	332	/* Allocate thread locals. */
	333	root = scm_make_root (scm_root->handle);
	334	/* Make thread. */
	335	SCM_NEWCELL (thread);
	336	SCM_DEFER_INTS;
	337	SCM_SETCAR (thread, scm_tc16_thread);
	338	argl = scm_cons2 (root, thread, argl);
	339
	340	/* thread mustn't start until we've built the info struct */
	341	pthread_kernel_lock++;
	342
	343	/* initialize and create the thread. */
	344	pthread_attr_init (&attr);
	345	pthread_attr_setschedpolicy (&attr, SCHED_RR);
	346
	347	pthread_create (&t, &attr, launch_thread, (void *) argl);
	348	pthread_attr_destroy (&attr);
	349
	350	/* push the info onto the dequeue */
	351	info->q.flink = infos.flink;
	352	info->q.blink = &infos;
	353	infos.flink->blink = &info->q;
	354	infos.flink = &info->q;
	355	/* pthread_create filled in the initial SP -- profitons-en ! */
	356	info->stack_top = (void *) (t->THREAD_SP);
	357	info->thread = t;
	358	info->root = SCM_ROOT_STATE (root);
	359	SCM_SETCDR (thread, t);
	360	SCM_ALLOW_INTS;
	361
	362	/* we're now ready for the thread to begin */
	363	pthread_kernel_lock--;
	364
	365	/* Return to old dynamic context. */
	366	scm_dowinds (old_winds, - scm_ilength (old_winds));
	367	}
	368
	369	return thread;
	370	}
	371
	372	#ifdef __STDC__
	373	SCM
	374	scm_join_thread (SCM t)
	375	#else
	376	SCM
	377	scm_join_thread (t)
	378	SCM t;
	379	#endif
	380	{
381	void *value;
382	pthread_join (SCM_THREAD_DATA (t), &value);
383	return SCM_BOOL_T;
384	}
385
386	#ifdef __STDC__
387	SCM
388	scm_yield ()
389	#else
390	SCM
391	scm_yield ()
392	#endif
393	{
394	pthread_yield ();
395	return SCM_BOOL_T;
396	}
397
398	#ifdef __STDC__
399	SCM
400	scm_make_mutex ()
401	#else
402	SCM
403	scm_make_mutex ()
404	#endif
405	{
406	SCM m;
407	pthread_mutex_t data = (pthread_mutex_t ) scm_must_malloc (sizeof (pthread_mutex_t), "mutex");
23a62151	408	SCM_NEWSMOB (m,scm_tc16_mutex, data);
7bfd3b9e JB	409	pthread_mutex_init (SCM_MUTEX_DATA (m), NULL);
	410	return m;
	411	}
	412
	413	#ifdef __STDC__
	414	SCM
	415	scm_lock_mutex (SCM m)
	416	#else
	417	SCM
	418	scm_lock_mutex (m)
	419	SCM m;
	420	#endif
	421	{
	422	SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);
	423	pthread_mutex_lock (SCM_MUTEX_DATA (m));
	424	return SCM_BOOL_T;
	425	}
	426
	427	#ifdef __STDC__
	428	SCM
	429	scm_unlock_mutex (SCM m)
	430	#else
	431	SCM
	432	scm_unlock_mutex (m)
	433	SCM m;
	434	#endif
	435	{
	436	SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_unlock_mutex);
	437	pthread_mutex_unlock (SCM_MUTEX_DATA (m));
	438	return SCM_BOOL_T;
	439	}
	440
	441	#ifdef __STDC__
	442	SCM
	443	scm_make_condition_variable ()
	444	#else
	445	SCM
	446	scm_make_condition_variable ()
	447	#endif
	448	{
	449	SCM c;
	450	pthread_cond_t data = (pthread_cond_t ) scm_must_malloc (sizeof (pthread_cond_t), "condvar");
23a62151	451	SCM_NEWSMOB (c, scm_tc16_condvar, data);
7bfd3b9e JB	452	pthread_cond_init (SCM_CONDVAR_DATA (c), NULL);
	453	return c;
	454	}
	455
	456	#ifdef __STDC__
	457	SCM
	458	scm_wait_condition_variable (SCM c, SCM m)
	459	#else
	460	SCM
	461	scm_wait_condition_variable (c, m)
	462	SCM c;
	463	SCM m;
	464	#endif
	465	{
	466	SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c),
	467	c,
	468	SCM_ARG1,
	469	s_wait_condition_variable);
	470	SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m),
	471	m,
	472	SCM_ARG2,
	473	s_wait_condition_variable);
	474	pthread_cond_wait (SCM_CONDVAR_DATA (m), SCM_MUTEX_DATA (c));
	475	return SCM_BOOL_T;
	476	}
	477
	478	#ifdef __STDC__
	479	SCM
	480	scm_signal_condition_variable (SCM c)
	481	#else
	482	SCM
	483	scm_signal_condition_variable (c)
	484	SCM c;
	485	#endif
	486	{
	487	SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c),
	488	c,
	489	SCM_ARG1,
	490	s_signal_condition_variable);
	491	pthread_cond_signal (SCM_CONDVAR_DATA (c));
	492	return SCM_BOOL_T;
	493	}