1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library 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 GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 #include "libguile/_scm.h" /* config.h, _scm.h, __scm.h should be first */
28 #include "libguile/validate.h"
29 #include "libguile/coop-pthreads.h"
30 #include "libguile/root.h"
31 #include "libguile/eval.h"
32 #include "libguile/async.h"
33 #include "libguile/ports.h"
34 #include "libguile/gc.h"
43 return scm_cons (SCM_EOL, SCM_EOL);
47 enqueue (SCM q, SCM t)
49 SCM c = scm_cons (t, SCM_EOL);
50 if (scm_is_null (SCM_CAR (q)))
53 SCM_SETCDR (SCM_CDR (q), c);
65 SCM_SETCAR (q, SCM_CDR (c));
66 if (scm_is_null (SCM_CAR (q)))
67 SCM_SETCDR (q, SCM_EOL);
75 typedef struct scm_copt_thread {
77 /* A condition variable for sleeping on.
79 pthread_cond_t sleep_cond;
81 /* A link for waiting queues.
83 struct scm_copt_thread *next_waiting;
92 /* For keeping track of the stack and registers. */
100 make_thread (SCM creation_protects)
103 scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread");
104 z = scm_cell (scm_tc16_thread, (scm_t_bits)t);
106 t->result = creation_protects;
108 t->joining_threads = make_queue ();
109 pthread_cond_init (&t->sleep_cond, NULL);
114 init_thread_creator (SCM thread, pthread_t th, scm_root_state *r)
116 scm_copt_thread *t = SCM_THREAD_DATA(thread);
120 // fprintf (stderr, "%ld created %ld\n", pthread_self (), th);
125 init_thread_creatant (SCM thread, SCM_STACKITEM *base)
127 scm_copt_thread *t = SCM_THREAD_DATA(thread);
133 thread_mark (SCM obj)
135 scm_copt_thread *t = SCM_THREAD_DATA (obj);
136 scm_gc_mark (t->result);
137 scm_gc_mark (t->joining_threads);
138 return t->root->handle;
142 thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
144 scm_copt_thread *t = SCM_THREAD_DATA (exp);
145 scm_puts ("#<thread ", port);
146 scm_uintprint ((scm_t_bits)t, 16, port);
147 if (t->pthread != -1)
149 scm_putc (' ', port);
150 scm_intprint (t->pthread, 10, port);
153 scm_puts (" (exited)", port);
154 scm_putc ('>', port);
159 thread_free (SCM obj)
161 scm_copt_thread *t = SCM_THREAD_DATA (obj);
162 if (t->pthread != -1)
164 scm_gc_free (t, sizeof (*t), "thread");
170 /* POSIX mutexes are not necessarily fair but since we'd like to use a
171 mutex for scheduling, we build a fair one on top of POSIX.
174 typedef struct fair_mutex {
175 pthread_mutex_t lock;
176 scm_copt_thread *owner;
177 scm_copt_thread *next_waiting, *last_waiting;
181 fair_mutex_init (fair_mutex *m)
183 pthread_mutex_init (&m->lock, NULL);
185 m->next_waiting = NULL;
186 m->last_waiting = NULL;
190 fair_mutex_lock_1 (fair_mutex *m, scm_copt_thread *t)
192 if (m->owner == NULL)
196 t->next_waiting = NULL;
198 m->last_waiting->next_waiting = t;
204 pthread_cond_wait (&t->sleep_cond, &m->lock);
206 while (m->owner != t);
207 assert (m->next_waiting == t);
208 m->next_waiting = t->next_waiting;
209 if (m->next_waiting == NULL)
210 m->last_waiting = NULL;
212 pthread_mutex_unlock (&m->lock);
216 fair_mutex_lock (fair_mutex *m, scm_copt_thread *t)
218 pthread_mutex_lock (&m->lock);
219 fair_mutex_lock_1 (m, t);
223 fair_mutex_unlock_1 (fair_mutex *m)
226 pthread_mutex_lock (&m->lock);
227 // fprintf (stderr, "%ld unlocking\n", m->owner->pthread);
228 if ((t = m->next_waiting) != NULL)
231 pthread_cond_signal (&t->sleep_cond);
235 // fprintf (stderr, "%ld unlocked\n", pthread_self ());
239 fair_mutex_unlock (fair_mutex *m)
241 fair_mutex_unlock_1 (m);
242 pthread_mutex_unlock (&m->lock);
245 /* Temporarily give up the mutex. This function makes sure that we
246 are on the wait queue before starting the next thread. Otherwise
247 the next thread might preempt us and we will have a hard time
248 getting on the wait queue.
252 fair_mutex_yield (fair_mutex *m)
254 scm_copt_thread *self, *next;
256 pthread_mutex_lock (&m->lock);
260 if ((next = m->next_waiting) == NULL)
262 /* No use giving it up. */
263 pthread_mutex_unlock (&m->lock);
270 self->next_waiting = NULL;
272 m->last_waiting->next_waiting = self;
274 m->next_waiting = self;
275 m->last_waiting = self;
277 /* wake up next thread
281 pthread_cond_signal (&next->sleep_cond);
287 pthread_cond_wait (&self->sleep_cond, &m->lock);
289 while (m->owner != self);
290 assert (m->next_waiting == self);
291 m->next_waiting = self->next_waiting;
292 if (m->next_waiting == NULL)
293 m->last_waiting = NULL;
295 pthread_mutex_unlock (&m->lock);
299 fair_mutex_yield (fair_mutex *m)
301 scm_copt_thread *self = m->owner;
302 fair_mutex_unlock_1 (m);
303 fair_mutex_lock_1 (m, self);
308 fair_cond_wait (pthread_cond_t *c, fair_mutex *m)
310 scm_copt_thread *t = m->owner;
311 fair_mutex_unlock_1 (m);
312 pthread_cond_wait (c, &m->lock);
313 fair_mutex_lock_1 (m, t);
316 /* Return 1 when the mutex was signalled and 0 when not. */
318 fair_cond_timedwait (pthread_cond_t *c, fair_mutex *m, scm_t_timespec *at)
321 scm_copt_thread *t = m->owner;
322 fair_mutex_unlock_1 (m);
323 res = pthread_cond_timedwait (c, &m->lock, at); /* XXX - signals? */
324 fair_mutex_lock_1 (m, t);
330 /* When a thread wants to execute Guile functions, it locks the
334 static fair_mutex guile_mutex;
336 static SCM cur_thread;
337 void *scm_i_copt_thread_data;
340 scm_i_copt_set_thread_data (void *data)
342 scm_copt_thread *t = SCM_THREAD_DATA (cur_thread);
343 scm_i_copt_thread_data = data;
344 t->root = (scm_root_state *)data;
348 resume (scm_copt_thread *t)
350 cur_thread = t->handle;
351 scm_i_copt_thread_data = t->root;
356 enter_guile (scm_copt_thread *t)
358 fair_mutex_lock (&guile_mutex, t);
362 static scm_copt_thread *
365 SCM cur = cur_thread;
366 scm_copt_thread *c = SCM_THREAD_DATA (cur);
368 /* record top of stack for the GC */
369 c->top = (SCM_STACKITEM *)&c;
370 /* save registers. */
371 SCM_FLUSH_REGISTER_WINDOWS;
377 static scm_copt_thread *
380 scm_copt_thread *c = suspend ();
381 fair_mutex_unlock (&guile_mutex);
385 int scm_i_switch_counter;
390 /* Testing guile_mutex.next_waiting without locking guile_mutex.lock
391 is OK since the outcome is not critical. Even when it changes
392 after the test, we do the right thing.
394 if (guile_mutex.next_waiting)
396 scm_copt_thread *t = suspend ();
397 fair_mutex_yield (&guile_mutex);
403 /* Put the current thread to sleep until it is explicitely unblocked.
408 scm_copt_thread *t = suspend ();
409 fair_cond_wait (&t->sleep_cond, &guile_mutex);
413 /* Put the current thread to sleep until it is explicitely unblocked
414 or until a signal arrives or until time AT (absolute time) is
415 reached. Return 1 when it has been unblocked; 0 otherwise.
418 timed_block (scm_t_timespec *at)
421 scm_copt_thread *t = suspend ();
422 res = fair_cond_timedwait (&t->sleep_cond, &guile_mutex, at);
427 /* Unblock a sleeping thread.
430 unblock (scm_copt_thread *t)
432 pthread_cond_signal (&t->sleep_cond);
435 /*** Thread creation */
437 static SCM all_threads;
438 static int thread_count;
440 typedef struct launch_data {
443 scm_t_catch_body body;
445 scm_t_catch_handler handler;
450 body_bootstrip (launch_data* data)
452 /* First save the new root continuation */
453 data->rootcont = scm_root->rootcont;
454 return (data->body) (data->body_data);
455 // return scm_call_0 (data->body);
459 handler_bootstrip (launch_data* data, SCM tag, SCM throw_args)
461 scm_root->rootcont = data->rootcont;
462 return (data->handler) (data->handler_data, tag, throw_args);
463 // return scm_apply_1 (data->handler, tag, throw_args);
467 really_launch (SCM_STACKITEM *base, launch_data *data)
469 SCM thread = data->thread;
470 scm_copt_thread *t = SCM_THREAD_DATA (thread);
471 init_thread_creatant (thread, base);
474 data->rootcont = SCM_BOOL_F;
476 scm_internal_cwdr ((scm_t_catch_body) body_bootstrip,
478 (scm_t_catch_handler) handler_bootstrip,
482 pthread_detach (t->pthread);
483 all_threads = scm_delq (thread, all_threads);
490 launch_thread (void *p)
492 really_launch ((SCM_STACKITEM *)&p, (launch_data *)p);
497 create_thread (scm_t_catch_body body, void *body_data,
498 scm_t_catch_handler handler, void *handler_data,
503 /* Make new thread. The first thing the new thread will do is to
504 lock guile_mutex. Thus, we can safely complete its
505 initialization after creating it. While the new thread starts,
506 all its data is protected via all_threads.
514 /* Unwind wind chain. */
515 old_winds = scm_dynwinds;
516 scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
518 /* Allocate thread locals. */
519 root = scm_make_root (scm_root->handle);
520 data = scm_malloc (sizeof (launch_data));
523 thread = make_thread (protects);
524 data->thread = thread;
526 data->body_data = body_data;
527 data->handler = handler;
528 data->handler_data = handler_data;
529 pthread_create (&th, NULL, launch_thread, (void *) data);
530 init_thread_creator (thread, th, SCM_ROOT_STATE (root));
531 all_threads = scm_cons (thread, all_threads);
534 /* Return to old dynamic context. */
535 scm_dowinds (old_winds, - scm_ilength (old_winds));
542 scm_call_with_new_thread (SCM argl)
543 #define FUNC_NAME s_call_with_new_thread
547 /* Check arguments. */
549 register SCM args = argl;
550 if (!scm_is_pair (args))
551 SCM_WRONG_NUM_ARGS ();
552 thunk = SCM_CAR (args);
553 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)),
556 s_call_with_new_thread);
557 args = SCM_CDR (args);
558 if (!scm_is_pair (args))
559 SCM_WRONG_NUM_ARGS ();
560 handler = SCM_CAR (args);
561 SCM_ASSERT (scm_is_true (scm_procedure_p (handler)),
564 s_call_with_new_thread);
565 if (!scm_is_null (SCM_CDR (args)))
566 SCM_WRONG_NUM_ARGS ();
569 return create_thread ((scm_t_catch_body) scm_call_0, thunk,
570 (scm_t_catch_handler) scm_apply_1, handler,
576 scm_spawn_thread (scm_t_catch_body body, void *body_data,
577 scm_t_catch_handler handler, void *handler_data)
579 return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F);
584 /* We implement our own mutex type since we want them to be 'fair', we
585 want to do fancy things while waiting for them (like running
586 asyncs) and we want to support waiting on many things at once.
587 Also, we might add things that are nice for debugging.
590 typedef struct scm_copt_mutex {
591 /* the thread currently owning the mutex, or SCM_BOOL_F. */
593 /* how much the owner owns us. */
595 /* the threads waiting for this mutex. */
602 scm_copt_mutex *m = SCM_MUTEX_DATA (mx);
603 scm_gc_mark (m->owner);
610 SCM mx = scm_make_smob (scm_tc16_mutex);
611 scm_copt_mutex *m = SCM_MUTEX_DATA (mx);
612 m->owner = SCM_BOOL_F;
614 m->waiting = make_queue ();
619 scm_lock_mutex (SCM mx)
620 #define FUNC_NAME s_lock_mutex
623 SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
624 m = SCM_MUTEX_DATA (mx);
626 if (m->owner == SCM_BOOL_F)
627 m->owner = cur_thread;
628 else if (m->owner == cur_thread)
632 while (m->owner != cur_thread)
634 enqueue (m->waiting, cur_thread);
644 scm_try_mutex (SCM mx)
645 #define FUNC_NAME s_try_mutex
648 SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
649 m = SCM_MUTEX_DATA (mx);
651 if (m->owner == SCM_BOOL_F)
652 m->owner = cur_thread;
653 else if (m->owner == cur_thread)
662 scm_unlock_mutex (SCM mx)
663 #define FUNC_NAME s_unlock_mutex
666 SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
667 m = SCM_MUTEX_DATA (mx);
669 if (m->owner != cur_thread)
671 if (m->owner == SCM_BOOL_F)
672 SCM_MISC_ERROR ("mutex not locked", SCM_EOL);
674 SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL);
676 else if (m->level > 0)
680 SCM next = dequeue (m->waiting);
681 if (scm_is_true (next))
684 unblock (SCM_THREAD_DATA (next));
688 m->owner = SCM_BOOL_F;
694 /*** Condition variables */
696 /* Like mutexes, we implement our own condition variables using the
700 /* yeah, we don't need a structure for this, but more things (like a
701 name) will likely follow... */
703 typedef struct scm_copt_cond {
704 /* the threads waiting for this condition. */
711 scm_copt_cond *c = SCM_CONDVAR_DATA (cv);
716 scm_make_condition_variable (void)
718 SCM cv = scm_make_smob (scm_tc16_condvar);
719 scm_copt_cond *c = SCM_CONDVAR_DATA (cv);
720 c->waiting = make_queue ();
725 scm_timed_wait_condition_variable (SCM cv, SCM mx, SCM t)
726 #define FUNC_NAME s_wait_condition_variable
729 scm_t_timespec waittime;
732 SCM_ASSERT (SCM_CONDVARP (cv),
735 s_wait_condition_variable);
736 SCM_ASSERT (SCM_MUTEXP (mx),
739 s_wait_condition_variable);
744 SCM_VALIDATE_UINT_COPY (3, SCM_CAR(t), waittime.tv_sec);
745 SCM_VALIDATE_UINT_COPY (3, SCM_CDR(t), waittime.tv_nsec);
746 waittime.tv_nsec *= 1000;
750 SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec);
751 waittime.tv_nsec = 0;
755 c = SCM_CONDVAR_DATA (cv);
757 enqueue (c->waiting, cur_thread);
758 scm_unlock_mutex (mx);
765 res = timed_block (&waittime);
767 return scm_from_bool (res);
772 scm_signal_condition_variable (SCM cv)
773 #define FUNC_NAME s_signal_condition_variable
777 SCM_ASSERT (SCM_CONDVARP (cv),
780 s_signal_condition_variable);
781 c = SCM_CONDVAR_DATA (cv);
782 if (scm_is_true (th = dequeue (c->waiting)))
783 unblock (SCM_THREAD_DATA (th));
789 scm_broadcast_condition_variable (SCM cv)
790 #define FUNC_NAME s_broadcast_condition_variable
794 SCM_ASSERT (SCM_CONDVARP (cv),
797 s_signal_condition_variable);
798 c = SCM_CONDVAR_DATA (cv);
799 while (scm_is_true (th = dequeue (c->waiting)))
800 unblock (SCM_THREAD_DATA (th));
805 /*** Initialization */
808 scm_threads_init (SCM_STACKITEM *base)
810 scm_tc16_thread = scm_make_smob_type ("thread", 0);
811 scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_copt_mutex));
812 scm_tc16_condvar = scm_make_smob_type ("condition-variable",
813 sizeof (scm_copt_cond));
815 scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT;
817 fair_mutex_init (&guile_mutex);
819 cur_thread = make_thread (SCM_BOOL_F);
820 enter_guile (SCM_THREAD_DATA (cur_thread));
821 /* root is set later from init.c */
822 init_thread_creator (cur_thread, pthread_self(), NULL);
823 init_thread_creatant (cur_thread, base);
826 scm_gc_register_root (&all_threads);
827 all_threads = scm_cons (cur_thread, SCM_EOL);
829 scm_set_smob_mark (scm_tc16_thread, thread_mark);
830 scm_set_smob_print (scm_tc16_thread, thread_print);
831 scm_set_smob_free (scm_tc16_thread, thread_free);
833 scm_set_smob_mark (scm_tc16_mutex, mutex_mark);
835 scm_set_smob_mark (scm_tc16_condvar, cond_mark);
838 /*** Marking stacks */
840 /* XXX - what to do with this? Do we need to handle this for blocked
844 # define SCM_MARK_BACKING_STORE() do { \
846 SCM_STACKITEM * top, * bot; \
848 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
849 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
850 / sizeof (SCM_STACKITEM))); \
851 bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \
852 top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
853 scm_mark_locations (bot, top - bot); } while (0)
855 # define SCM_MARK_BACKING_STORE()
859 scm_threads_mark_stacks (void)
862 for (c = all_threads; !scm_is_null (c); c = SCM_CDR (c))
864 scm_copt_thread *t = SCM_THREAD_DATA (SCM_CAR (c));
867 /* Not fully initialized yet. */
873 /* stack_len is long rather than sizet in order to guarantee
874 that &stack_len is long aligned */
875 #if SCM_STACK_GROWS_UP
876 long stack_len = ((SCM_STACKITEM *) (&t) -
877 (SCM_STACKITEM *) thread->base);
879 /* Protect from the C stack. This must be the first marking
880 * done because it provides information about what objects
881 * are "in-use" by the C code. "in-use" objects are those
882 * for which the information about length and base address must
883 * remain usable. This requirement is stricter than a liveness
884 * requirement -- in particular, it constrains the implementation
887 SCM_FLUSH_REGISTER_WINDOWS;
888 /* This assumes that all registers are saved into the jmp_buf */
889 setjmp (scm_save_regs_gc_mark);
890 scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
891 ((size_t) sizeof scm_save_regs_gc_mark
892 / sizeof (SCM_STACKITEM)));
894 scm_mark_locations (((size_t) t->base,
897 long stack_len = ((SCM_STACKITEM *) t->base -
898 (SCM_STACKITEM *) (&t));
900 /* Protect from the C stack. This must be the first marking
901 * done because it provides information about what objects
902 * are "in-use" by the C code. "in-use" objects are those
903 * for which the information about length and base address must
904 * remain usable. This requirement is stricter than a liveness
905 * requirement -- in particular, it constrains the implementation
908 SCM_FLUSH_REGISTER_WINDOWS;
909 /* This assumes that all registers are saved into the jmp_buf */
910 setjmp (scm_save_regs_gc_mark);
911 scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
912 ((size_t) sizeof scm_save_regs_gc_mark
913 / sizeof (SCM_STACKITEM)));
915 scm_mark_locations ((SCM_STACKITEM *) &t,
921 /* Suspended thread */
922 #if SCM_STACK_GROWS_UP
923 long stack_len = t->top - t->base;
924 scm_mark_locations (t->base, stack_len);
926 long stack_len = t->base - t->top;
927 scm_mark_locations (t->top, stack_len);
929 scm_mark_locations ((SCM_STACKITEM *) t->regs,
930 ((size_t) sizeof(t->regs)
931 / sizeof (SCM_STACKITEM)));
939 scm_internal_select (int nfds,
940 SELECT_TYPE *readfds,
941 SELECT_TYPE *writefds,
942 SELECT_TYPE *exceptfds,
943 struct timeval *timeout)
946 scm_copt_thread *c = leave_guile ();
947 res = select (nfds, readfds, writefds, exceptfds, timeout);
961 scm_thread_usleep (unsigned long usec)
963 scm_copt_thread *c = leave_guile ();
970 scm_thread_sleep (unsigned long sec)
973 scm_copt_thread *c = leave_guile ();
982 scm_current_thread (void)
988 scm_all_threads (void)
994 scm_i_thread_root (SCM thread)
996 if (thread == cur_thread)
997 return scm_i_copt_thread_data;
999 return ((scm_copt_thread *)SCM_THREAD_DATA (thread))->root;
1003 scm_join_thread (SCM thread)
1004 #define FUNC_NAME s_join_thread
1009 SCM_VALIDATE_THREAD (1, thread);
1011 t = SCM_THREAD_DATA (thread);
1012 if (t->pthread != -1)
1014 scm_copt_thread *c = leave_guile ();
1015 pthread_join (t->pthread, NULL);
1019 t->result = SCM_BOOL_F;
1025 scm_c_thread_exited_p (SCM thread)
1026 #define FUNC_NAME s_scm_thread_exited_p
1029 SCM_VALIDATE_THREAD (1, thread);
1030 t = SCM_THREAD_DATA (thread);
1031 return t->pthread == -1;