1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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/boehm-gc.h"
22 #include "libguile/_scm.h"
31 #include <string.h> /* for memset used by FD_ZERO on Solaris 10 */
38 #include "libguile/validate.h"
39 #include "libguile/root.h"
40 #include "libguile/eval.h"
41 #include "libguile/async.h"
42 #include "libguile/ports.h"
43 #include "libguile/threads.h"
44 #include "libguile/dynwind.h"
45 #include "libguile/iselect.h"
46 #include "libguile/fluids.h"
47 #include "libguile/continuations.h"
48 #include "libguile/gc.h"
49 #include "libguile/init.h"
50 #include "libguile/scmsigs.h"
51 #include "libguile/strings.h"
55 # define ETIMEDOUT WSAETIMEDOUT
59 # define pipe(fd) _pipe (fd, 256, O_BINARY)
60 #endif /* __MINGW32__ */
63 to_timespec (SCM t
, scm_t_timespec
*waittime
)
67 waittime
->tv_sec
= scm_to_ulong (SCM_CAR (t
));
68 waittime
->tv_nsec
= scm_to_ulong (SCM_CDR (t
)) * 1000;
72 double time
= scm_to_double (t
);
73 double sec
= scm_c_truncate (time
);
75 waittime
->tv_sec
= (long) sec
;
76 waittime
->tv_nsec
= (long) ((time
- sec
) * 1000000000);
82 /* Make an empty queue data structure.
87 return scm_cons (SCM_EOL
, SCM_EOL
);
90 /* Put T at the back of Q and return a handle that can be used with
91 remqueue to remove T from Q again.
94 enqueue (SCM q
, SCM t
)
96 SCM c
= scm_cons (t
, SCM_EOL
);
97 if (scm_is_null (SCM_CDR (q
)))
100 SCM_SETCDR (SCM_CAR (q
), c
);
105 /* Remove the element that the handle C refers to from the queue Q. C
106 must have been returned from a call to enqueue. The return value
107 is zero when the element referred to by C has already been removed.
108 Otherwise, 1 is returned.
111 remqueue (SCM q
, SCM c
)
114 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
116 if (scm_is_eq (p
, c
))
118 if (scm_is_eq (c
, SCM_CAR (q
)))
119 SCM_SETCAR (q
, SCM_CDR (c
));
120 SCM_SETCDR (prev
, SCM_CDR (c
));
128 /* Remove the front-most element from the queue Q and return it.
129 Return SCM_BOOL_F when Q is empty.
139 SCM_SETCDR (q
, SCM_CDR (c
));
140 if (scm_is_null (SCM_CDR (q
)))
141 SCM_SETCAR (q
, SCM_EOL
);
146 /*** Thread smob routines */
150 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
152 /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
153 struct. A cast like "(unsigned long) t->pthread" is a syntax error in
154 the struct case, hence we go via a union, and extract according to the
155 size of pthread_t. */
163 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
164 scm_i_pthread_t p
= t
->pthread
;
167 if (sizeof (p
) == sizeof (unsigned short))
169 else if (sizeof (p
) == sizeof (unsigned int))
171 else if (sizeof (p
) == sizeof (unsigned long))
176 scm_puts ("#<thread ", port
);
177 scm_uintprint (id
, 10, port
);
178 scm_puts (" (", port
);
179 scm_uintprint ((scm_t_bits
)t
, 16, port
);
180 scm_puts (")>", port
);
185 thread_free (SCM obj
)
187 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
189 scm_gc_free (t
, sizeof (*t
), "thread");
193 /*** Blocking on queues. */
195 /* See also scm_i_queue_async_cell for how such a block is
199 /* Put the current thread on QUEUE and go to sleep, waiting for it to
200 be woken up by a call to 'unblock_from_queue', or to be
201 interrupted. Upon return of this function, the current thread is
202 no longer on QUEUE, even when the sleep has been interrupted.
204 The QUEUE data structure is assumed to be protected by MUTEX and
205 the caller of block_self must hold MUTEX. It will be atomically
206 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
208 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
211 When WAITTIME is not NULL, the sleep will be aborted at that time.
213 The return value of block_self is an errno value. It will be zero
214 when the sleep has been successfully completed by a call to
215 unblock_from_queue, EINTR when it has been interrupted by the
216 delivery of a system async, and ETIMEDOUT when the timeout has
219 The system asyncs themselves are not executed by block_self.
222 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
223 const scm_t_timespec
*waittime
)
225 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
229 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
234 q_handle
= enqueue (queue
, t
->handle
);
235 if (waittime
== NULL
)
236 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
238 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
240 /* When we are still on QUEUE, we have been interrupted. We
241 report this only when no other error (such as a timeout) has
244 if (remqueue (queue
, q_handle
) && err
== 0)
247 scm_i_reset_sleep (t
);
253 /* Wake up the first thread on QUEUE, if any. The caller must hold
254 the mutex that protects QUEUE. The awoken thread is returned, or
255 #f when the queue was empty.
258 unblock_from_queue (SCM queue
)
260 SCM thread
= dequeue (queue
);
261 if (scm_is_true (thread
))
262 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
266 /* Getting into and out of guile mode.
269 /* Ken Raeburn observes that the implementation of suspend and resume
270 (and the things that build on top of them) are very likely not
271 correct (see below). We will need fix this eventually, and that's
272 why scm_leave_guile/scm_enter_guile are not exported in the API.
276 Consider this sequence:
278 Function foo, called in Guile mode, calls suspend (maybe indirectly
279 through scm_leave_guile), which does this:
281 // record top of stack for the GC
282 t->top = SCM_STACK_PTR (&t); // just takes address of automatic
285 SCM_FLUSH_REGISTER_WINDOWS; // sparc only
286 setjmp (t->regs); // here's most of the magic
290 Function foo has a SCM value X, a handle on a non-immediate object, in
291 a caller-saved register R, and it's the only reference to the object
294 The compiler wants to use R in suspend, so it pushes the current
295 value, X, into a stack slot which will be reloaded on exit from
296 suspend; then it loads stuff into R and goes about its business. The
297 setjmp call saves (some of) the current registers, including R, which
298 no longer contains X. (This isn't a problem for a normal
299 setjmp/longjmp situation, where longjmp would be called before
300 setjmp's caller returns; the old value for X would be loaded back from
301 the stack after the longjmp, before the function returned.)
303 So, suspend returns, loading X back into R (and invalidating the jump
304 buffer) in the process. The caller foo then goes off and calls a
305 bunch of other functions out of Guile mode, occasionally storing X on
306 the stack again, but, say, much deeper on the stack than suspend's
307 stack frame went, and the stack slot where suspend had written X has
308 long since been overwritten with other values.
310 Okay, nothing actively broken so far. Now, let garbage collection
311 run, triggered by another thread.
313 The thread calling foo is out of Guile mode at the time, so the
314 garbage collector just scans a range of stack addresses. Too bad that
315 X isn't stored there. So the pointed-to storage goes onto the free
316 list, and I think you can see where things go from there.
318 Is there anything I'm missing that'll prevent this scenario from
319 happening? I mean, aside from, "well, suspend and scm_leave_guile
320 don't have many local variables, so they probably won't need to save
321 any registers on most systems, so we hope everything will wind up in
322 the jump buffer and we'll just get away with it"?
324 (And, going the other direction, if scm_leave_guile and suspend push
325 the stack pointer over onto a new page, and foo doesn't make further
326 function calls and thus the stack pointer no longer includes that
327 page, are we guaranteed that the kernel cannot release the now-unused
328 stack page that contains the top-of-stack pointer we just saved? I
329 don't know if any OS actually does that. If it does, we could get
330 faults in garbage collection.)
332 I don't think scm_without_guile has to have this problem, as it gets
333 more control over the stack handling -- but it should call setjmp
334 itself. I'd probably try something like:
336 // record top of stack for the GC
337 t->top = SCM_STACK_PTR (&t);
339 SCM_FLUSH_REGISTER_WINDOWS;
344 ... though even that's making some assumptions about the stack
345 ordering of local variables versus caller-saved registers.
347 For something like scm_leave_guile to work, I don't think it can just
348 rely on invalidated jump buffers. A valid jump buffer, and a handle
349 on the stack state at the point when the jump buffer was initialized,
350 together, would work fine, but I think then we're talking about macros
351 invoking setjmp in the caller's stack frame, and requiring that the
352 caller of scm_leave_guile also call scm_enter_guile before returning,
353 kind of like pthread_cleanup_push/pop calls that have to be paired up
354 in a function. (In fact, the pthread ones have to be paired up
355 syntactically, as if they might expand to a compound statement
356 incorporating the user's code, and invoking a compiler's
357 exception-handling primitives. Which might be something to think
358 about for cases where Guile is used with C++ exceptions or
362 scm_i_pthread_key_t scm_i_thread_key
;
365 resume (scm_i_thread
*t
)
368 if (t
->clear_freelists_p
)
370 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
371 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
372 t
->clear_freelists_p
= 0;
376 typedef void* scm_t_guile_ticket
;
379 scm_enter_guile (scm_t_guile_ticket ticket
)
381 scm_i_thread
*t
= (scm_i_thread
*)ticket
;
384 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
389 static scm_i_thread
*
392 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
394 /* record top of stack for the GC */
395 t
->top
= SCM_STACK_PTR (&t
);
396 /* save registers. */
397 SCM_FLUSH_REGISTER_WINDOWS
;
402 static scm_t_guile_ticket
405 scm_i_thread
*t
= suspend ();
406 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
407 return (scm_t_guile_ticket
) t
;
410 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
411 static scm_i_thread
*all_threads
= NULL
;
412 static int thread_count
;
414 static SCM scm_i_default_dynamic_state
;
416 /* Perform first stage of thread initialisation, in non-guile mode.
419 guilify_self_1 (SCM_STACKITEM
*base
)
421 scm_i_thread
*t
= scm_gc_malloc (sizeof (scm_i_thread
), "thread");
423 t
->pthread
= scm_i_pthread_self ();
424 t
->handle
= SCM_BOOL_F
;
425 t
->result
= SCM_BOOL_F
;
426 t
->cleanup_handler
= SCM_BOOL_F
;
427 t
->mutexes
= SCM_EOL
;
428 t
->join_queue
= SCM_EOL
;
429 t
->dynamic_state
= SCM_BOOL_F
;
430 t
->dynwinds
= SCM_EOL
;
431 t
->active_asyncs
= SCM_EOL
;
433 t
->pending_asyncs
= 1;
434 t
->last_debug_frame
= NULL
;
437 /* Calculate and store off the base of this thread's register
438 backing store (RBS). Unfortunately our implementation(s) of
439 scm_ia64_register_backing_store_base are only reliable for the
440 main thread. For other threads, therefore, find out the current
441 top of the RBS, and use that as a maximum. */
442 t
->register_backing_store_base
= scm_ia64_register_backing_store_base ();
447 bsp
= scm_ia64_ar_bsp (&ctx
);
448 if (t
->register_backing_store_base
> bsp
)
449 t
->register_backing_store_base
= bsp
;
452 t
->continuation_root
= SCM_EOL
;
453 t
->continuation_base
= base
;
454 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
455 t
->sleep_mutex
= NULL
;
456 t
->sleep_object
= SCM_BOOL_F
;
458 /* XXX - check for errors. */
459 pipe (t
->sleep_pipe
);
460 scm_i_pthread_mutex_init (&t
->heap_mutex
, NULL
);
461 scm_i_pthread_mutex_init (&t
->admin_mutex
, NULL
);
462 t
->clear_freelists_p
= 0;
464 t
->current_mark_stack_ptr
= NULL
;
465 t
->current_mark_stack_limit
= NULL
;
469 t
->freelist
= SCM_EOL
;
470 t
->freelist2
= SCM_EOL
;
471 SCM_SET_FREELIST_LOC (scm_i_freelist
, &t
->freelist
);
472 SCM_SET_FREELIST_LOC (scm_i_freelist2
, &t
->freelist2
);
474 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
476 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
478 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
479 t
->next_thread
= all_threads
;
482 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
485 /* Perform second stage of thread initialisation, in guile mode.
488 guilify_self_2 (SCM parent
)
490 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
492 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
494 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
495 t
->continuation_base
= t
->base
;
497 if (scm_is_true (parent
))
498 t
->dynamic_state
= scm_make_dynamic_state (parent
);
500 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
502 t
->join_queue
= make_queue ();
509 /* We implement our own mutex type since we want them to be 'fair', we
510 want to do fancy things while waiting for them (like running
511 asyncs) and we might want to add things that are nice for
516 scm_i_pthread_mutex_t lock
;
518 int level
; /* how much the owner owns us. <= 1 for non-recursive mutexes */
520 int recursive
; /* allow recursive locking? */
521 int unchecked_unlock
; /* is it an error to unlock an unlocked mutex? */
522 int allow_external_unlock
; /* is it an error to unlock a mutex that is not
523 owned by the current thread? */
525 SCM waiting
; /* the threads waiting for this mutex. */
528 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
529 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
531 /* Perform thread tear-down, in guile mode.
534 do_thread_exit (void *v
)
536 scm_i_thread
*t
= (scm_i_thread
*) v
;
538 if (!scm_is_false (t
->cleanup_handler
))
540 SCM ptr
= t
->cleanup_handler
;
542 t
->cleanup_handler
= SCM_BOOL_F
;
543 t
->result
= scm_internal_catch (SCM_BOOL_T
,
544 (scm_t_catch_body
) scm_call_0
, ptr
,
545 scm_handle_by_message_noexit
, NULL
);
548 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
551 close (t
->sleep_pipe
[0]);
552 close (t
->sleep_pipe
[1]);
553 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
556 while (!scm_is_null (t
->mutexes
))
558 SCM mutex
= SCM_CAR (t
->mutexes
);
559 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
560 scm_i_pthread_mutex_lock (&m
->lock
);
562 unblock_from_queue (m
->waiting
);
564 scm_i_pthread_mutex_unlock (&m
->lock
);
565 t
->mutexes
= SCM_CDR (t
->mutexes
);
568 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
574 on_thread_exit (void *v
)
576 /* This handler is executed in non-guile mode. */
577 scm_i_thread
*t
= (scm_i_thread
*) v
, **tp
;
579 scm_i_pthread_setspecific (scm_i_thread_key
, v
);
581 /* Ensure the signal handling thread has been launched, because we might be
583 scm_i_ensure_signal_delivery_thread ();
585 /* Unblocking the joining threads needs to happen in guile mode
586 since the queue is a SCM data structure. */
588 /* Note: `scm_with_guile ()' invokes `GC_local_malloc ()', which accesses
589 thread-local storage (TLS). If said storage is accessed using
590 `pthread_getspecific ()', then it may be inaccessible at this point,
591 having been destroyed earlier, since the invocation order of destructors
592 associated with pthread keys is unspecified:
594 http://www.opengroup.org/onlinepubs/009695399/functions/pthread_key_create.html
596 Thus, `libgc' *must* be compiled with `USE_COMPILER_TLS' for this code
598 scm_with_guile (do_thread_exit
, v
);
600 /* Removing ourself from the list of all threads needs to happen in
601 non-guile mode since all SCM values on our stack become
602 unprotected once we are no longer in the list. */
603 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
604 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
607 *tp
= t
->next_thread
;
612 /* If there's only one other thread, it could be the signal delivery
613 thread, so we need to notify it to shut down by closing its read pipe.
614 If it's not the signal delivery thread, then closing the read pipe isn't
616 if (thread_count
<= 1)
617 scm_i_close_signal_pipe ();
619 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
621 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
624 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
627 init_thread_key (void)
629 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
632 /* Perform any initializations necessary to bring the current thread
633 into guile mode, initializing Guile itself, if necessary.
635 BASE is the stack base to use with GC.
637 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
638 which case the default dynamic state is used.
640 Return zero when the thread was in guile mode already; otherwise
645 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
649 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
651 if ((t
= SCM_I_CURRENT_THREAD
) == NULL
)
653 /* This thread has not been guilified yet.
656 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
657 if (scm_initialized_p
== 0)
659 /* First thread ever to enter Guile. Run the full
662 scm_i_init_guile (base
);
663 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
667 /* Guile is already initialized, but this thread enters it for
668 the first time. Only initialize this thread.
670 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
671 guilify_self_1 (base
);
672 guilify_self_2 (parent
);
678 /* This thread is already guilified but not in guile mode, just
681 XXX - base might be lower than when this thread was first
684 scm_enter_guile ((scm_t_guile_ticket
) t
);
689 /* Thread is already in guile mode. Nothing to do.
695 #if SCM_USE_PTHREAD_THREADS
697 #if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
698 /* This method for GNU/Linux and perhaps some other systems.
699 It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
700 available on them. */
701 #define HAVE_GET_THREAD_STACK_BASE
703 static SCM_STACKITEM
*
704 get_thread_stack_base ()
710 pthread_getattr_np (pthread_self (), &attr
);
711 pthread_attr_getstack (&attr
, &start
, &size
);
712 end
= (char *)start
+ size
;
714 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
715 for the main thread, but we can use scm_get_stack_base in that
719 #ifndef PTHREAD_ATTR_GETSTACK_WORKS
720 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
721 return (SCM_STACKITEM
*) GC_stackbottom
;
725 #if SCM_STACK_GROWS_UP
733 #elif HAVE_PTHREAD_GET_STACKADDR_NP
734 /* This method for MacOS X.
735 It'd be nice if there was some documentation on pthread_get_stackaddr_np,
736 but as of 2006 there's nothing obvious at apple.com. */
737 #define HAVE_GET_THREAD_STACK_BASE
738 static SCM_STACKITEM
*
739 get_thread_stack_base ()
741 return pthread_get_stackaddr_np (pthread_self ());
744 #elif defined (__MINGW32__)
745 /* This method for mingw. In mingw the basic scm_get_stack_base can be used
746 in any thread. We don't like hard-coding the name of a system, but there
747 doesn't seem to be a cleaner way of knowing scm_get_stack_base can
749 #define HAVE_GET_THREAD_STACK_BASE
750 static SCM_STACKITEM
*
751 get_thread_stack_base ()
753 return (SCM_STACKITEM
*) GC_stackbottom
;
756 #endif /* pthread methods of get_thread_stack_base */
758 #else /* !SCM_USE_PTHREAD_THREADS */
760 #define HAVE_GET_THREAD_STACK_BASE
762 static SCM_STACKITEM
*
763 get_thread_stack_base ()
765 return (SCM_STACKITEM
*) GC_stackbottom
;
768 #endif /* !SCM_USE_PTHREAD_THREADS */
770 #ifdef HAVE_GET_THREAD_STACK_BASE
775 scm_i_init_thread_for_guile (get_thread_stack_base (),
776 scm_i_default_dynamic_state
);
782 scm_with_guile (void *(*func
)(void *), void *data
)
784 return scm_i_with_guile_and_parent (func
, data
,
785 scm_i_default_dynamic_state
);
788 SCM_UNUSED
static void
789 scm_leave_guile_cleanup (void *x
)
795 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
, SCM parent
)
799 SCM_STACKITEM base_item
;
801 really_entered
= scm_i_init_thread_for_guile (&base_item
, parent
);
804 scm_i_pthread_cleanup_push (scm_leave_guile_cleanup
, NULL
);
805 res
= scm_c_with_continuation_barrier (func
, data
);
806 scm_i_pthread_cleanup_pop (0);
810 res
= scm_c_with_continuation_barrier (func
, data
);
816 scm_without_guile (void *(*func
)(void *), void *data
)
819 scm_t_guile_ticket t
;
820 t
= scm_leave_guile ();
826 /*** Thread creation */
833 scm_i_pthread_mutex_t mutex
;
834 scm_i_pthread_cond_t cond
;
838 really_launch (void *d
)
840 launch_data
*data
= (launch_data
*)d
;
841 SCM thunk
= data
->thunk
, handler
= data
->handler
;
844 t
= SCM_I_CURRENT_THREAD
;
846 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
847 data
->thread
= scm_current_thread ();
848 scm_i_pthread_cond_signal (&data
->cond
);
849 scm_i_pthread_mutex_unlock (&data
->mutex
);
851 if (SCM_UNBNDP (handler
))
852 t
->result
= scm_call_0 (thunk
);
854 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
860 launch_thread (void *d
)
862 launch_data
*data
= (launch_data
*)d
;
863 scm_i_pthread_detach (scm_i_pthread_self ());
864 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
868 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
869 (SCM thunk
, SCM handler
),
870 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
871 "returning a new thread object representing the thread. The procedure\n"
872 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
874 "When @var{handler} is specified, then @var{thunk} is called from\n"
875 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
876 "handler. This catch is established inside the continuation barrier.\n"
878 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
879 "the @emph{exit value} of the thread and the thread is terminated.")
880 #define FUNC_NAME s_scm_call_with_new_thread
886 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
887 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
888 handler
, SCM_ARG2
, FUNC_NAME
);
890 data
.parent
= scm_current_dynamic_state ();
892 data
.handler
= handler
;
893 data
.thread
= SCM_BOOL_F
;
894 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
895 scm_i_pthread_cond_init (&data
.cond
, NULL
);
897 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
898 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
901 scm_i_pthread_mutex_unlock (&data
.mutex
);
905 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
906 scm_i_pthread_mutex_unlock (&data
.mutex
);
914 scm_t_catch_body body
;
916 scm_t_catch_handler handler
;
919 scm_i_pthread_mutex_t mutex
;
920 scm_i_pthread_cond_t cond
;
924 really_spawn (void *d
)
926 spawn_data
*data
= (spawn_data
*)d
;
927 scm_t_catch_body body
= data
->body
;
928 void *body_data
= data
->body_data
;
929 scm_t_catch_handler handler
= data
->handler
;
930 void *handler_data
= data
->handler_data
;
931 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
933 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
934 data
->thread
= scm_current_thread ();
935 scm_i_pthread_cond_signal (&data
->cond
);
936 scm_i_pthread_mutex_unlock (&data
->mutex
);
939 t
->result
= body (body_data
);
941 t
->result
= scm_internal_catch (SCM_BOOL_T
,
943 handler
, handler_data
);
949 spawn_thread (void *d
)
951 spawn_data
*data
= (spawn_data
*)d
;
952 scm_i_pthread_detach (scm_i_pthread_self ());
953 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
958 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
959 scm_t_catch_handler handler
, void *handler_data
)
965 data
.parent
= scm_current_dynamic_state ();
967 data
.body_data
= body_data
;
968 data
.handler
= handler
;
969 data
.handler_data
= handler_data
;
970 data
.thread
= SCM_BOOL_F
;
971 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
972 scm_i_pthread_cond_init (&data
.cond
, NULL
);
974 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
975 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
978 scm_i_pthread_mutex_unlock (&data
.mutex
);
982 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
983 scm_i_pthread_mutex_unlock (&data
.mutex
);
988 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
990 "Move the calling thread to the end of the scheduling queue.")
991 #define FUNC_NAME s_scm_yield
993 return scm_from_bool (scm_i_sched_yield ());
997 SCM_DEFINE (scm_cancel_thread
, "cancel-thread", 1, 0, 0,
999 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
1000 "cannot be the current thread, and if @var{thread} has already terminated or "
1001 "been signaled to terminate, this function is a no-op.")
1002 #define FUNC_NAME s_scm_cancel_thread
1004 scm_i_thread
*t
= NULL
;
1006 SCM_VALIDATE_THREAD (1, thread
);
1007 t
= SCM_I_THREAD_DATA (thread
);
1008 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1012 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1013 scm_i_pthread_cancel (t
->pthread
);
1016 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1018 return SCM_UNSPECIFIED
;
1022 SCM_DEFINE (scm_set_thread_cleanup_x
, "set-thread-cleanup!", 2, 0, 0,
1023 (SCM thread
, SCM proc
),
1024 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
1025 "This handler will be called when the thread exits.")
1026 #define FUNC_NAME s_scm_set_thread_cleanup_x
1030 SCM_VALIDATE_THREAD (1, thread
);
1031 if (!scm_is_false (proc
))
1032 SCM_VALIDATE_THUNK (2, proc
);
1034 t
= SCM_I_THREAD_DATA (thread
);
1035 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1037 if (!(t
->exited
|| t
->canceled
))
1038 t
->cleanup_handler
= proc
;
1040 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1042 return SCM_UNSPECIFIED
;
1046 SCM_DEFINE (scm_thread_cleanup
, "thread-cleanup", 1, 0, 0,
1048 "Return the cleanup handler installed for the thread @var{thread}.")
1049 #define FUNC_NAME s_scm_thread_cleanup
1054 SCM_VALIDATE_THREAD (1, thread
);
1056 t
= SCM_I_THREAD_DATA (thread
);
1057 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1058 ret
= (t
->exited
|| t
->canceled
) ? SCM_BOOL_F
: t
->cleanup_handler
;
1059 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1065 SCM
scm_join_thread (SCM thread
)
1067 return scm_join_thread_timed (thread
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1070 SCM_DEFINE (scm_join_thread_timed
, "join-thread", 1, 2, 0,
1071 (SCM thread
, SCM timeout
, SCM timeoutval
),
1072 "Suspend execution of the calling thread until the target @var{thread} "
1073 "terminates, unless the target @var{thread} has already terminated. ")
1074 #define FUNC_NAME s_scm_join_thread_timed
1077 scm_t_timespec ctimeout
, *timeout_ptr
= NULL
;
1078 SCM res
= SCM_BOOL_F
;
1080 if (! (SCM_UNBNDP (timeoutval
)))
1083 SCM_VALIDATE_THREAD (1, thread
);
1084 if (scm_is_eq (scm_current_thread (), thread
))
1085 SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL
);
1087 t
= SCM_I_THREAD_DATA (thread
);
1088 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1090 if (! SCM_UNBNDP (timeout
))
1092 to_timespec (timeout
, &ctimeout
);
1093 timeout_ptr
= &ctimeout
;
1102 int err
= block_self (t
->join_queue
, thread
, &t
->admin_mutex
,
1112 else if (err
== ETIMEDOUT
)
1115 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1117 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1121 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1127 SCM_DEFINE (scm_thread_p
, "thread?", 1, 0, 0,
1129 "Return @code{#t} if @var{obj} is a thread.")
1130 #define FUNC_NAME s_scm_thread_p
1132 return SCM_I_IS_THREAD(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1138 fat_mutex_free (SCM mx
)
1140 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1141 scm_i_pthread_mutex_destroy (&m
->lock
);
1142 scm_gc_free (m
, sizeof (fat_mutex
), "mutex");
1147 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1149 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1150 scm_puts ("#<mutex ", port
);
1151 scm_uintprint ((scm_t_bits
)m
, 16, port
);
1152 scm_puts (">", port
);
1157 make_fat_mutex (int recursive
, int unchecked_unlock
, int external_unlock
)
1162 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
1163 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
1164 m
->owner
= SCM_BOOL_F
;
1167 m
->recursive
= recursive
;
1168 m
->unchecked_unlock
= unchecked_unlock
;
1169 m
->allow_external_unlock
= external_unlock
;
1171 m
->waiting
= SCM_EOL
;
1172 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
1173 m
->waiting
= make_queue ();
1177 SCM
scm_make_mutex (void)
1179 return scm_make_mutex_with_flags (SCM_EOL
);
1182 SCM_SYMBOL (unchecked_unlock_sym
, "unchecked-unlock");
1183 SCM_SYMBOL (allow_external_unlock_sym
, "allow-external-unlock");
1184 SCM_SYMBOL (recursive_sym
, "recursive");
1186 SCM_DEFINE (scm_make_mutex_with_flags
, "make-mutex", 0, 0, 1,
1188 "Create a new mutex. ")
1189 #define FUNC_NAME s_scm_make_mutex_with_flags
1191 int unchecked_unlock
= 0, external_unlock
= 0, recursive
= 0;
1194 while (! scm_is_null (ptr
))
1196 SCM flag
= SCM_CAR (ptr
);
1197 if (scm_is_eq (flag
, unchecked_unlock_sym
))
1198 unchecked_unlock
= 1;
1199 else if (scm_is_eq (flag
, allow_external_unlock_sym
))
1200 external_unlock
= 1;
1201 else if (scm_is_eq (flag
, recursive_sym
))
1204 SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag
));
1205 ptr
= SCM_CDR (ptr
);
1207 return make_fat_mutex (recursive
, unchecked_unlock
, external_unlock
);
1211 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
1213 "Create a new recursive mutex. ")
1214 #define FUNC_NAME s_scm_make_recursive_mutex
1216 return make_fat_mutex (1, 0, 0);
1220 SCM_SYMBOL (scm_abandoned_mutex_error_key
, "abandoned-mutex-error");
1223 fat_mutex_lock (SCM mutex
, scm_t_timespec
*timeout
, SCM owner
, int *ret
)
1225 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1227 SCM new_owner
= SCM_UNBNDP (owner
) ? scm_current_thread() : owner
;
1228 SCM err
= SCM_BOOL_F
;
1230 struct timeval current_time
;
1232 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1238 m
->owner
= new_owner
;
1241 if (SCM_I_IS_THREAD (new_owner
))
1243 scm_i_thread
*t
= SCM_I_THREAD_DATA (new_owner
);
1244 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1245 t
->mutexes
= scm_cons (mutex
, t
->mutexes
);
1246 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1251 else if (SCM_I_IS_THREAD (m
->owner
) && scm_c_thread_exited_p (m
->owner
))
1253 m
->owner
= new_owner
;
1254 err
= scm_cons (scm_abandoned_mutex_error_key
,
1255 scm_from_locale_string ("lock obtained on abandoned "
1260 else if (scm_is_eq (m
->owner
, new_owner
))
1269 err
= scm_cons (scm_misc_error_key
,
1270 scm_from_locale_string ("mutex already locked "
1278 if (timeout
!= NULL
)
1280 gettimeofday (¤t_time
, NULL
);
1281 if (current_time
.tv_sec
> timeout
->tv_sec
||
1282 (current_time
.tv_sec
== timeout
->tv_sec
&&
1283 current_time
.tv_usec
* 1000 > timeout
->tv_nsec
))
1289 block_self (m
->waiting
, mutex
, &m
->lock
, timeout
);
1290 scm_i_pthread_mutex_unlock (&m
->lock
);
1292 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1295 scm_i_pthread_mutex_unlock (&m
->lock
);
1299 SCM
scm_lock_mutex (SCM mx
)
1301 return scm_lock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1304 SCM_DEFINE (scm_lock_mutex_timed
, "lock-mutex", 1, 2, 0,
1305 (SCM m
, SCM timeout
, SCM owner
),
1306 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
1307 "blocks until the mutex becomes available. The function returns when "
1308 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
1309 "a thread already owns will succeed right away and will not block the "
1310 "thread. That is, Guile's mutexes are @emph{recursive}. ")
1311 #define FUNC_NAME s_scm_lock_mutex_timed
1315 scm_t_timespec cwaittime
, *waittime
= NULL
;
1317 SCM_VALIDATE_MUTEX (1, m
);
1319 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1321 to_timespec (timeout
, &cwaittime
);
1322 waittime
= &cwaittime
;
1325 exception
= fat_mutex_lock (m
, waittime
, owner
, &ret
);
1326 if (!scm_is_false (exception
))
1327 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1328 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1333 scm_dynwind_lock_mutex (SCM mutex
)
1335 scm_dynwind_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
1336 SCM_F_WIND_EXPLICITLY
);
1337 scm_dynwind_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
1338 SCM_F_WIND_EXPLICITLY
);
1341 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1343 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1344 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1345 #define FUNC_NAME s_scm_try_mutex
1349 scm_t_timespec cwaittime
, *waittime
= NULL
;
1351 SCM_VALIDATE_MUTEX (1, mutex
);
1353 to_timespec (scm_from_int(0), &cwaittime
);
1354 waittime
= &cwaittime
;
1356 exception
= fat_mutex_lock (mutex
, waittime
, SCM_UNDEFINED
, &ret
);
1357 if (!scm_is_false (exception
))
1358 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1359 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1363 /*** Fat condition variables */
1366 scm_i_pthread_mutex_t lock
;
1367 SCM waiting
; /* the threads waiting for this condition. */
1370 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1371 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1374 fat_mutex_unlock (SCM mutex
, SCM cond
,
1375 const scm_t_timespec
*waittime
, int relock
)
1377 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1379 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1380 int err
= 0, ret
= 0;
1382 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1384 SCM owner
= m
->owner
;
1386 if (!scm_is_eq (owner
, scm_current_thread ()))
1390 if (!m
->unchecked_unlock
)
1392 scm_i_pthread_mutex_unlock (&m
->lock
);
1393 scm_misc_error (NULL
, "mutex not locked", SCM_EOL
);
1395 owner
= scm_current_thread ();
1397 else if (!m
->allow_external_unlock
)
1399 scm_i_pthread_mutex_unlock (&m
->lock
);
1400 scm_misc_error (NULL
, "mutex not locked by current thread", SCM_EOL
);
1404 if (! (SCM_UNBNDP (cond
)))
1406 c
= SCM_CONDVAR_DATA (cond
);
1411 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1415 m
->owner
= unblock_from_queue (m
->waiting
);
1417 scm_i_pthread_mutex_unlock (&m
->lock
);
1421 err
= block_self (c
->waiting
, cond
, &c
->lock
, waittime
);
1428 else if (err
== ETIMEDOUT
)
1433 else if (err
!= EINTR
)
1436 scm_i_pthread_mutex_unlock (&c
->lock
);
1437 scm_syserror (NULL
);
1443 scm_lock_mutex_timed (mutex
, SCM_UNDEFINED
, owner
);
1444 scm_i_pthread_mutex_unlock (&c
->lock
);
1448 scm_i_pthread_mutex_unlock (&c
->lock
);
1453 scm_remember_upto_here_2 (cond
, mutex
);
1455 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1463 m
->owner
= unblock_from_queue (m
->waiting
);
1465 scm_i_pthread_mutex_unlock (&m
->lock
);
1472 SCM
scm_unlock_mutex (SCM mx
)
1474 return scm_unlock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1477 SCM_DEFINE (scm_unlock_mutex_timed
, "unlock-mutex", 1, 2, 0,
1478 (SCM mx
, SCM cond
, SCM timeout
),
1479 "Unlocks @var{mutex} if the calling thread owns the lock on "
1480 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1481 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1482 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1483 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1484 "with a call to @code{unlock-mutex}. Only the last call to "
1485 "@code{unlock-mutex} will actually unlock the mutex. ")
1486 #define FUNC_NAME s_scm_unlock_mutex_timed
1488 scm_t_timespec cwaittime
, *waittime
= NULL
;
1490 SCM_VALIDATE_MUTEX (1, mx
);
1491 if (! (SCM_UNBNDP (cond
)))
1493 SCM_VALIDATE_CONDVAR (2, cond
);
1495 if (! (SCM_UNBNDP (timeout
)))
1497 to_timespec (timeout
, &cwaittime
);
1498 waittime
= &cwaittime
;
1502 return fat_mutex_unlock (mx
, cond
, waittime
, 0) ? SCM_BOOL_T
: SCM_BOOL_F
;
1506 SCM_DEFINE (scm_mutex_p
, "mutex?", 1, 0, 0,
1508 "Return @code{#t} if @var{obj} is a mutex.")
1509 #define FUNC_NAME s_scm_mutex_p
1511 return SCM_MUTEXP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1515 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1517 "Return the thread owning @var{mx}, or @code{#f}.")
1518 #define FUNC_NAME s_scm_mutex_owner
1521 fat_mutex
*m
= NULL
;
1523 SCM_VALIDATE_MUTEX (1, mx
);
1524 m
= SCM_MUTEX_DATA (mx
);
1525 scm_i_pthread_mutex_lock (&m
->lock
);
1527 scm_i_pthread_mutex_unlock (&m
->lock
);
1533 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1535 "Return the lock level of mutex @var{mx}.")
1536 #define FUNC_NAME s_scm_mutex_level
1538 SCM_VALIDATE_MUTEX (1, mx
);
1539 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1543 SCM_DEFINE (scm_mutex_locked_p
, "mutex-locked?", 1, 0, 0,
1545 "Returns @code{#t} if the mutex @var{mx} is locked.")
1546 #define FUNC_NAME s_scm_mutex_locked_p
1548 SCM_VALIDATE_MUTEX (1, mx
);
1549 return SCM_MUTEX_DATA (mx
)->level
> 0 ? SCM_BOOL_T
: SCM_BOOL_F
;
1554 fat_cond_free (SCM mx
)
1556 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1557 scm_i_pthread_mutex_destroy (&c
->lock
);
1558 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1563 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1565 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1566 scm_puts ("#<condition-variable ", port
);
1567 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1568 scm_puts (">", port
);
1572 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1574 "Make a new condition variable.")
1575 #define FUNC_NAME s_scm_make_condition_variable
1580 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1581 scm_i_pthread_mutex_init (&c
->lock
, 0);
1582 c
->waiting
= SCM_EOL
;
1583 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1584 c
->waiting
= make_queue ();
1589 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1590 (SCM cv
, SCM mx
, SCM t
),
1591 "Wait until @var{cond-var} has been signalled. While waiting, "
1592 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1593 "is locked again when this function returns. When @var{time} is given, "
1594 "it specifies a point in time where the waiting should be aborted. It "
1595 "can be either a integer as returned by @code{current-time} or a pair "
1596 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1597 "mutex is locked and @code{#f} is returned. When the condition "
1598 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1600 #define FUNC_NAME s_scm_timed_wait_condition_variable
1602 scm_t_timespec waittime
, *waitptr
= NULL
;
1604 SCM_VALIDATE_CONDVAR (1, cv
);
1605 SCM_VALIDATE_MUTEX (2, mx
);
1607 if (!SCM_UNBNDP (t
))
1609 to_timespec (t
, &waittime
);
1610 waitptr
= &waittime
;
1613 return fat_mutex_unlock (mx
, cv
, waitptr
, 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
1618 fat_cond_signal (fat_cond
*c
)
1620 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1621 unblock_from_queue (c
->waiting
);
1622 scm_i_pthread_mutex_unlock (&c
->lock
);
1625 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1627 "Wake up one thread that is waiting for @var{cv}")
1628 #define FUNC_NAME s_scm_signal_condition_variable
1630 SCM_VALIDATE_CONDVAR (1, cv
);
1631 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1637 fat_cond_broadcast (fat_cond
*c
)
1639 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1640 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1642 scm_i_pthread_mutex_unlock (&c
->lock
);
1645 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1647 "Wake up all threads that are waiting for @var{cv}. ")
1648 #define FUNC_NAME s_scm_broadcast_condition_variable
1650 SCM_VALIDATE_CONDVAR (1, cv
);
1651 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1656 SCM_DEFINE (scm_condition_variable_p
, "condition-variable?", 1, 0, 0,
1658 "Return @code{#t} if @var{obj} is a condition variable.")
1659 #define FUNC_NAME s_scm_condition_variable_p
1661 return SCM_CONDVARP(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1665 /*** Marking stacks */
1667 /* XXX - what to do with this? Do we need to handle this for blocked
1671 # define SCM_MARK_BACKING_STORE() do { \
1673 SCM_STACKITEM * top, * bot; \
1674 getcontext (&ctx); \
1675 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1676 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1677 / sizeof (SCM_STACKITEM))); \
1678 bot = (SCM_STACKITEM *) SCM_I_CURRENT_THREAD->register_backing_store_base; \
1679 top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
1680 scm_mark_locations (bot, top - bot); } while (0)
1682 # define SCM_MARK_BACKING_STORE()
1690 scm_std_select (int nfds
,
1691 SELECT_TYPE
*readfds
,
1692 SELECT_TYPE
*writefds
,
1693 SELECT_TYPE
*exceptfds
,
1694 struct timeval
*timeout
)
1697 int res
, eno
, wakeup_fd
;
1698 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1699 scm_t_guile_ticket ticket
;
1701 if (readfds
== NULL
)
1703 FD_ZERO (&my_readfds
);
1704 readfds
= &my_readfds
;
1707 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1710 wakeup_fd
= t
->sleep_pipe
[0];
1711 ticket
= scm_leave_guile ();
1712 FD_SET (wakeup_fd
, readfds
);
1713 if (wakeup_fd
>= nfds
)
1715 res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1718 scm_enter_guile (ticket
);
1720 scm_i_reset_sleep (t
);
1722 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1725 read (wakeup_fd
, &dummy
, 1);
1726 FD_CLR (wakeup_fd
, readfds
);
1738 /* Convenience API for blocking while in guile mode. */
1740 #if SCM_USE_PTHREAD_THREADS
1743 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1745 scm_t_guile_ticket t
= scm_leave_guile ();
1746 int res
= scm_i_pthread_mutex_lock (mutex
);
1747 scm_enter_guile (t
);
1752 do_unlock (void *data
)
1754 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1758 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1760 scm_i_scm_pthread_mutex_lock (mutex
);
1761 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1765 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1767 scm_t_guile_ticket t
= scm_leave_guile ();
1768 int res
= scm_i_pthread_cond_wait (cond
, mutex
);
1769 scm_enter_guile (t
);
1774 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1775 scm_i_pthread_mutex_t
*mutex
,
1776 const scm_t_timespec
*wt
)
1778 scm_t_guile_ticket t
= scm_leave_guile ();
1779 int res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1780 scm_enter_guile (t
);
1787 scm_std_usleep (unsigned long usecs
)
1790 tv
.tv_usec
= usecs
% 1000000;
1791 tv
.tv_sec
= usecs
/ 1000000;
1792 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1793 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1797 scm_std_sleep (unsigned int secs
)
1802 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1808 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1810 "Return the thread that called this function.")
1811 #define FUNC_NAME s_scm_current_thread
1813 return SCM_I_CURRENT_THREAD
->handle
;
1818 scm_c_make_list (size_t n
, SCM fill
)
1822 res
= scm_cons (fill
, res
);
1826 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1828 "Return a list of all threads.")
1829 #define FUNC_NAME s_scm_all_threads
1831 /* We can not allocate while holding the thread_admin_mutex because
1832 of the way GC is done.
1834 int n
= thread_count
;
1836 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1838 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1840 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1842 if (t
!= scm_i_signal_delivery_thread
)
1844 SCM_SETCAR (*l
, t
->handle
);
1845 l
= SCM_CDRLOC (*l
);
1850 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1855 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1857 "Return @code{#t} iff @var{thread} has exited.\n")
1858 #define FUNC_NAME s_scm_thread_exited_p
1860 return scm_from_bool (scm_c_thread_exited_p (thread
));
1865 scm_c_thread_exited_p (SCM thread
)
1866 #define FUNC_NAME s_scm_thread_exited_p
1869 SCM_VALIDATE_THREAD (1, thread
);
1870 t
= SCM_I_THREAD_DATA (thread
);
1875 static scm_i_pthread_cond_t wake_up_cond
;
1876 int scm_i_thread_go_to_sleep
;
1877 static int threads_initialized_p
= 0;
1880 scm_i_thread_put_to_sleep ()
1882 if (threads_initialized_p
)
1887 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1889 /* Signal all threads to go to sleep
1891 scm_i_thread_go_to_sleep
= 1;
1892 for (t
= all_threads
; t
; t
= t
->next_thread
)
1893 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
1894 scm_i_thread_go_to_sleep
= 0;
1899 scm_i_thread_invalidate_freelists ()
1901 /* thread_admin_mutex is already locked. */
1904 for (t
= all_threads
; t
; t
= t
->next_thread
)
1905 if (t
!= SCM_I_CURRENT_THREAD
)
1906 t
->clear_freelists_p
= 1;
1910 scm_i_thread_wake_up ()
1912 if (threads_initialized_p
)
1916 scm_i_pthread_cond_broadcast (&wake_up_cond
);
1917 for (t
= all_threads
; t
; t
= t
->next_thread
)
1918 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
1919 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1920 scm_enter_guile ((scm_t_guile_ticket
) SCM_I_CURRENT_THREAD
);
1925 scm_i_thread_sleep_for_gc ()
1927 scm_i_thread
*t
= suspend ();
1928 scm_i_pthread_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1932 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
1934 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
1935 int scm_i_critical_section_level
= 0;
1937 static SCM dynwind_critical_section_mutex
;
1940 scm_dynwind_critical_section (SCM mutex
)
1942 if (scm_is_false (mutex
))
1943 mutex
= dynwind_critical_section_mutex
;
1944 scm_dynwind_lock_mutex (mutex
);
1945 scm_dynwind_block_asyncs ();
1948 /*** Initialization */
1950 scm_i_pthread_key_t scm_i_freelist
, scm_i_freelist2
;
1951 scm_i_pthread_mutex_t scm_i_misc_mutex
;
1953 #if SCM_USE_PTHREAD_THREADS
1954 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
1958 scm_threads_prehistory (SCM_STACKITEM
*base
)
1960 #if SCM_USE_PTHREAD_THREADS
1961 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
1962 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
1963 PTHREAD_MUTEX_RECURSIVE
);
1966 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
1967 scm_i_pthread_mutexattr_recursive
);
1968 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
1969 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
1970 scm_i_pthread_key_create (&scm_i_freelist
, NULL
);
1971 scm_i_pthread_key_create (&scm_i_freelist2
, NULL
);
1973 guilify_self_1 (base
);
1976 scm_t_bits scm_tc16_thread
;
1977 scm_t_bits scm_tc16_mutex
;
1978 scm_t_bits scm_tc16_condvar
;
1983 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
1984 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1985 scm_set_smob_free (scm_tc16_thread
, thread_free
); /* XXX: Could be removed */
1987 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
1988 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
1989 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
1991 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1993 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
1994 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
1996 scm_i_default_dynamic_state
= SCM_BOOL_F
;
1997 guilify_self_2 (SCM_BOOL_F
);
1998 threads_initialized_p
= 1;
2000 dynwind_critical_section_mutex
=
2001 scm_permanent_object (scm_make_recursive_mutex ());
2005 scm_init_threads_default_dynamic_state ()
2007 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
2008 scm_i_default_dynamic_state
= scm_permanent_object (state
);
2012 scm_init_thread_procs ()
2014 #include "libguile/threads.x"