1 /* Copyright (C) 1995, 1996, 1997, 1998, 2000 Free Software Foundation, Inc.
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)
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.
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
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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.
40 * If you do not wish that, delete this exception notice. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
48 #include "coop-threads.h"
50 /* A counter of the current number of threads */
51 size_t scm_thread_count
= 0;
53 /* This is included rather than compiled separately in order
54 to simplify the configuration mechanism. */
57 /* A count-down counter used to determine when to switch
59 size_t scm_switch_counter
= SCM_THREAD_SWITCH_COUNT
;
61 coop_m scm_critical_section_mutex
;
64 scm_threads_init (SCM_STACKITEM
*i
)
70 coop_global_main
.sto
= i
;
71 coop_global_main
.base
= i
;
72 coop_global_curr
= &coop_global_main
;
73 coop_all_qput (&coop_global_allq
, coop_global_curr
);
75 coop_mutex_init (&scm_critical_section_mutex
);
77 coop_global_main
.data
= 0; /* Initialized in init.c */
81 scm_threads_mark_stacks (void)
85 for (thread
= coop_global_allq
.t
.all_next
;
86 thread
!= NULL
; thread
= thread
->all_next
)
88 if (thread
== coop_global_curr
)
91 /* stack_len is long rather than sizet in order to guarantee
92 that &stack_len is long aligned */
94 long stack_len
= ((SCM_STACKITEM
*) (&thread
) -
95 (SCM_STACKITEM
*) thread
->base
);
97 /* Protect from the C stack. This must be the first marking
98 * done because it provides information about what objects
99 * are "in-use" by the C code. "in-use" objects are those
100 * for which the values from SCM_LENGTH and SCM_CHARS must remain
101 * usable. This requirement is stricter than a liveness
102 * requirement -- in particular, it constrains the implementation
105 SCM_FLUSH_REGISTER_WINDOWS
;
106 /* This assumes that all registers are saved into the jmp_buf */
107 setjmp (scm_save_regs_gc_mark
);
108 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
109 ((scm_sizet
) sizeof scm_save_regs_gc_mark
110 / sizeof (SCM_STACKITEM
)));
112 scm_mark_locations (((size_t) thread
->base
,
115 long stack_len
= ((SCM_STACKITEM
*) thread
->base
-
116 (SCM_STACKITEM
*) (&thread
));
118 /* Protect from the C stack. This must be the first marking
119 * done because it provides information about what objects
120 * are "in-use" by the C code. "in-use" objects are those
121 * for which the values from SCM_LENGTH and SCM_CHARS must remain
122 * usable. This requirement is stricter than a liveness
123 * requirement -- in particular, it constrains the implementation
126 SCM_FLUSH_REGISTER_WINDOWS
;
127 /* This assumes that all registers are saved into the jmp_buf */
128 setjmp (scm_save_regs_gc_mark
);
129 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
130 ((scm_sizet
) sizeof scm_save_regs_gc_mark
131 / sizeof (SCM_STACKITEM
)));
133 scm_mark_locations ((SCM_STACKITEM
*) &thread
,
139 /* Suspended thread */
140 #ifdef STACK_GROWS_UP
141 long stack_len
= ((SCM_STACKITEM
*) (thread
->sp
) -
142 (SCM_STACKITEM
*) thread
->base
);
144 scm_mark_locations ((size_t)thread
->base
,
147 long stack_len
= ((SCM_STACKITEM
*) thread
->base
-
148 (SCM_STACKITEM
*) (thread
->sp
));
150 /* Registers are already on the stack. No need to mark. */
152 scm_mark_locations ((SCM_STACKITEM
*) (size_t)thread
->sp
,
157 /* Mark this thread's root */
158 scm_gc_mark (((scm_root_state
*) thread
->data
) -> handle
);
162 /* NOTE: There are TWO mechanisms for starting a thread: The first one
163 is used when spawning a thread from Scheme, while the second one is
166 It might be argued that the first should be implemented in terms of
167 the second. The reason it isn't is that that would require an
168 extra unnecessary malloc (the thread_args structure). By providing
169 one pair of extra functions (c_launch_thread, scm_spawn_thread) the
170 Scheme threads are started more efficiently. */
172 /* This is the first thread spawning mechanism: threads from Scheme */
174 typedef struct scheme_launch_data
{
178 } scheme_launch_data
;
180 extern SCM
scm_apply (SCM
, SCM
, SCM
);
183 scheme_body_bootstrip (scheme_launch_data
* data
)
185 /* First save the new root continuation */
186 data
->rootcont
= scm_root
->rootcont
;
187 return scm_apply (data
->body
, SCM_EOL
, SCM_EOL
);
191 scheme_handler_bootstrip (scheme_launch_data
* data
, SCM tag
, SCM throw_args
)
193 scm_root
->rootcont
= data
->rootcont
;
194 return scm_apply (data
->handler
, scm_cons (tag
, throw_args
), SCM_EOL
);
198 scheme_launch_thread (void *p
)
200 /* The thread object will be GC protected by being a member of the
201 list given as argument to launch_thread. It will be marked
202 during the conservative sweep of the stack. */
203 register SCM argl
= (SCM
) p
;
204 SCM thread
= SCM_CAR (argl
);
205 scheme_launch_data data
;
206 data
.rootcont
= SCM_BOOL_F
;
207 data
.body
= SCM_CADR (argl
);
208 data
.handler
= SCM_CADDR (argl
);
209 scm_internal_cwdr ((scm_catch_body_t
) scheme_body_bootstrip
,
211 (scm_catch_handler_t
) scheme_handler_bootstrip
,
213 (SCM_STACKITEM
*) &thread
);
219 scm_call_with_new_thread (SCM argl
)
223 /* Check arguments. */
225 register SCM args
= argl
;
227 SCM_ASSERT (SCM_NIMP (args
),
228 scm_makfrom0str (s_call_with_new_thread
),
230 thunk
= SCM_CAR (args
);
231 SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk
)),
234 s_call_with_new_thread
);
235 args
= SCM_CDR (args
);
236 SCM_ASSERT (SCM_NIMP (args
),
237 scm_makfrom0str (s_call_with_new_thread
),
239 handler
= SCM_CAR (args
);
240 SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler
)),
243 s_call_with_new_thread
);
244 SCM_ASSERT (SCM_NULLP (SCM_CDR (args
)),
245 scm_makfrom0str (s_call_with_new_thread
),
249 /* Make new thread. */
254 /* Unwind wind chain. */
255 old_winds
= scm_dynwinds
;
256 scm_dowinds (SCM_EOL
, scm_ilength (scm_root
->dynwinds
));
258 /* Allocate thread locals. */
259 root
= scm_make_root (scm_root
->handle
);
261 SCM_NEWCELL (thread
);
263 SCM_SETCAR (thread
, scm_tc16_thread
);
264 argl
= scm_cons (thread
, argl
);
265 /* Note that we couldn't pass a pointer to argl as data since the
266 argl variable may not exist in memory when the thread starts. */
267 t
= coop_create (scheme_launch_thread
, (void *) argl
);
268 t
->data
= SCM_ROOT_STATE (root
);
269 SCM_SETCDR (thread
, t
);
271 /* Note that the following statement also could cause coop_yield.*/
274 /* We're now ready for the thread to begin. */
277 /* Return to old dynamic context. */
278 scm_dowinds (old_winds
, - scm_ilength (old_winds
));
284 /* This is the second thread spawning mechanism: threads from C */
286 typedef struct c_launch_data
{
291 scm_catch_body_t body
;
293 scm_catch_handler_t handler
;
298 c_body_bootstrip (c_launch_data
* data
)
300 /* First save the new root continuation */
301 data
->u
.rootcont
= scm_root
->rootcont
;
302 return (data
->body
) (data
->body_data
);
306 c_handler_bootstrip (c_launch_data
* data
, SCM tag
, SCM throw_args
)
308 scm_root
->rootcont
= data
->u
.rootcont
;
309 return (data
->handler
) (data
->handler_data
, tag
, throw_args
);
313 c_launch_thread (void *p
)
315 register c_launch_data
*data
= (c_launch_data
*) p
;
316 /* The thread object will be GC protected by being on this stack */
317 SCM thread
= data
->u
.thread
;
318 /* We must use the address of `thread', otherwise the compiler will
319 optimize it away. This is OK since the longest SCM_STACKITEM
321 scm_internal_cwdr ((scm_catch_body_t
) c_body_bootstrip
,
323 (scm_catch_handler_t
) c_handler_bootstrip
,
325 (SCM_STACKITEM
*) &thread
);
327 scm_must_free ((char *) data
);
331 scm_spawn_thread (scm_catch_body_t body
, void *body_data
,
332 scm_catch_handler_t handler
, void *handler_data
)
337 c_launch_data
*data
= (c_launch_data
*) scm_must_malloc (sizeof (*data
),
340 /* Unwind wind chain. */
341 old_winds
= scm_dynwinds
;
342 scm_dowinds (SCM_EOL
, scm_ilength (scm_root
->dynwinds
));
344 /* Allocate thread locals. */
345 root
= scm_make_root (scm_root
->handle
);
347 SCM_NEWCELL (thread
);
349 SCM_SETCAR (thread
, scm_tc16_thread
);
351 data
->u
.thread
= thread
;
353 data
->body_data
= body_data
;
354 data
->handler
= handler
;
355 data
->handler_data
= handler_data
;
357 t
= coop_create (c_launch_thread
, (void *) data
);
359 t
->data
= SCM_ROOT_STATE (root
);
360 SCM_SETCDR (thread
, t
);
362 /* Note that the following statement also could cause coop_yield.*/
365 /* We're now ready for the thread to begin. */
368 /* Return to old dynamic context. */
369 scm_dowinds (old_winds
, - scm_ilength (old_winds
));
375 scm_join_thread (SCM t
)
376 #define FUNC_NAME s_join_thread
378 SCM_VALIDATE_THREAD (1,t
);
379 coop_join (SCM_THREAD_DATA (t
));
388 scm_switch_counter
= SCM_THREAD_SWITCH_COUNT
;
395 scm_single_thread_p (void)
397 return (coop_global_runq
.tail
== &coop_global_runq
.t
403 scm_make_mutex (void)
406 coop_m
*data
= (coop_m
*) scm_must_malloc (sizeof (coop_m
), "mutex");
408 SCM_NEWSMOB (m
, scm_tc16_mutex
, data
);
409 coop_mutex_init (data
);
414 scm_lock_mutex (SCM m
)
416 SCM_ASSERT (SCM_MUTEXP (m
), m
, SCM_ARG1
, s_lock_mutex
);
417 coop_mutex_lock (SCM_MUTEX_DATA (m
));
422 scm_unlock_mutex (SCM m
)
424 SCM_ASSERT (SCM_MUTEXP (m
), m
, SCM_ARG1
, s_unlock_mutex
);
425 coop_mutex_unlock(SCM_MUTEX_DATA (m
));
428 scm_switch_counter
= SCM_THREAD_SWITCH_COUNT
;
435 scm_make_condition_variable (void)
438 coop_c
*data
= (coop_c
*) scm_must_malloc (sizeof (coop_c
), "condvar");
439 SCM_NEWSMOB (c
, scm_tc16_condvar
, data
);
440 coop_condition_variable_init (SCM_CONDVAR_DATA (c
));
445 scm_wait_condition_variable (SCM c
, SCM m
)
447 SCM_ASSERT (SCM_CONDVARP (c
),
450 s_wait_condition_variable
);
451 SCM_ASSERT (SCM_MUTEXP (m
),
454 s_wait_condition_variable
);
455 coop_condition_variable_wait_mutex (SCM_CONDVAR_DATA (c
),
461 scm_signal_condition_variable (SCM c
)
463 SCM_ASSERT (SCM_CONDVARP (c
),
466 s_signal_condition_variable
);
467 coop_condition_variable_signal (SCM_CONDVAR_DATA (c
));