1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 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
23 #include "libguile/_scm.h"
32 #include <string.h> /* for memset used by FD_ZERO on Solaris 10 */
39 #include "libguile/validate.h"
40 #include "libguile/root.h"
41 #include "libguile/eval.h"
42 #include "libguile/async.h"
43 #include "libguile/ports.h"
44 #include "libguile/threads.h"
45 #include "libguile/dynwind.h"
46 #include "libguile/iselect.h"
47 #include "libguile/fluids.h"
48 #include "libguile/continuations.h"
49 #include "libguile/gc.h"
50 #include "libguile/init.h"
54 # define ETIMEDOUT WSAETIMEDOUT
58 # define pipe(fd) _pipe (fd, 256, O_BINARY)
59 #endif /* __MINGW32__ */
63 /* Make an empty queue data structure.
68 return scm_cons (SCM_EOL
, SCM_EOL
);
71 /* Put T at the back of Q and return a handle that can be used with
72 remqueue to remove T from Q again.
75 enqueue (SCM q
, SCM t
)
77 SCM c
= scm_cons (t
, SCM_EOL
);
78 if (scm_is_null (SCM_CDR (q
)))
81 SCM_SETCDR (SCM_CAR (q
), c
);
86 /* Remove the element that the handle C refers to from the queue Q. C
87 must have been returned from a call to enqueue. The return value
88 is zero when the element referred to by C has already been removed.
89 Otherwise, 1 is returned.
92 remqueue (SCM q
, SCM c
)
95 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
99 if (scm_is_eq (c
, SCM_CAR (q
)))
100 SCM_SETCAR (q
, SCM_CDR (c
));
101 SCM_SETCDR (prev
, SCM_CDR (c
));
109 /* Remove the front-most element from the queue Q and return it.
110 Return SCM_BOOL_F when Q is empty.
120 SCM_SETCDR (q
, SCM_CDR (c
));
121 if (scm_is_null (SCM_CDR (q
)))
122 SCM_SETCAR (q
, SCM_EOL
);
127 /*** Thread smob routines */
130 thread_mark (SCM obj
)
132 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
133 scm_gc_mark (t
->result
);
134 scm_gc_mark (t
->join_queue
);
135 scm_gc_mark (t
->dynwinds
);
136 scm_gc_mark (t
->active_asyncs
);
137 scm_gc_mark (t
->continuation_root
);
138 return t
->dynamic_state
;
142 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
144 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
145 scm_puts ("#<thread ", port
);
146 scm_uintprint ((size_t)t
->pthread
, 10, port
);
147 scm_puts (" (", port
);
148 scm_uintprint ((scm_t_bits
)t
, 16, port
);
149 scm_puts (")>", port
);
154 thread_free (SCM obj
)
156 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
158 scm_gc_free (t
, sizeof (*t
), "thread");
162 /*** Blocking on queues. */
164 /* See also scm_i_queue_async_cell for how such a block is
168 /* Put the current thread on QUEUE and go to sleep, waiting for it to
169 be woken up by a call to 'unblock_from_queue', or to be
170 interrupted. Upon return of this function, the current thread is
171 no longer on QUEUE, even when the sleep has been interrupted.
173 The QUEUE data structure is assumed to be protected by MUTEX and
174 the caller of block_self must hold MUTEX. It will be atomically
175 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
177 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
180 When WAITTIME is not NULL, the sleep will be aborted at that time.
182 The return value of block_self is an errno value. It will be zero
183 when the sleep has been successfully completed by a call to
184 unblock_from_queue, EINTR when it has been interrupted by the
185 delivery of a system async, and ETIMEDOUT when the timeout has
188 The system asyncs themselves are not executed by block_self.
191 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
192 const scm_t_timespec
*waittime
)
194 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
198 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
203 q_handle
= enqueue (queue
, t
->handle
);
204 if (waittime
== NULL
)
205 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
207 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
209 /* When we are still on QUEUE, we have been interrupted. We
210 report this only when no other error (such as a timeout) has
213 if (remqueue (queue
, q_handle
) && err
== 0)
216 scm_i_reset_sleep (t
);
222 /* Wake up the first thread on QUEUE, if any. The caller must hold
223 the mutex that protects QUEUE. The awoken thread is returned, or
224 #f when the queue was empty.
227 unblock_from_queue (SCM queue
)
229 SCM thread
= dequeue (queue
);
230 if (scm_is_true (thread
))
231 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
235 /* Getting into and out of guile mode.
238 /* Ken Raeburn observes that the implementation of suspend and resume
239 (and the things that build on top of them) are very likely not
240 correct (see below). We will need fix this eventually, and that's
241 why scm_leave_guile/scm_enter_guile are not exported in the API.
245 Consider this sequence:
247 Function foo, called in Guile mode, calls suspend (maybe indirectly
248 through scm_leave_guile), which does this:
250 // record top of stack for the GC
251 t->top = SCM_STACK_PTR (&t); // just takes address of automatic
254 SCM_FLUSH_REGISTER_WINDOWS; // sparc only
255 setjmp (t->regs); // here's most of the magic
259 Function foo has a SCM value X, a handle on a non-immediate object, in
260 a caller-saved register R, and it's the only reference to the object
263 The compiler wants to use R in suspend, so it pushes the current
264 value, X, into a stack slot which will be reloaded on exit from
265 suspend; then it loads stuff into R and goes about its business. The
266 setjmp call saves (some of) the current registers, including R, which
267 no longer contains X. (This isn't a problem for a normal
268 setjmp/longjmp situation, where longjmp would be called before
269 setjmp's caller returns; the old value for X would be loaded back from
270 the stack after the longjmp, before the function returned.)
272 So, suspend returns, loading X back into R (and invalidating the jump
273 buffer) in the process. The caller foo then goes off and calls a
274 bunch of other functions out of Guile mode, occasionally storing X on
275 the stack again, but, say, much deeper on the stack than suspend's
276 stack frame went, and the stack slot where suspend had written X has
277 long since been overwritten with other values.
279 Okay, nothing actively broken so far. Now, let garbage collection
280 run, triggered by another thread.
282 The thread calling foo is out of Guile mode at the time, so the
283 garbage collector just scans a range of stack addresses. Too bad that
284 X isn't stored there. So the pointed-to storage goes onto the free
285 list, and I think you can see where things go from there.
287 Is there anything I'm missing that'll prevent this scenario from
288 happening? I mean, aside from, "well, suspend and scm_leave_guile
289 don't have many local variables, so they probably won't need to save
290 any registers on most systems, so we hope everything will wind up in
291 the jump buffer and we'll just get away with it"?
293 (And, going the other direction, if scm_leave_guile and suspend push
294 the stack pointer over onto a new page, and foo doesn't make further
295 function calls and thus the stack pointer no longer includes that
296 page, are we guaranteed that the kernel cannot release the now-unused
297 stack page that contains the top-of-stack pointer we just saved? I
298 don't know if any OS actually does that. If it does, we could get
299 faults in garbage collection.)
301 I don't think scm_without_guile has to have this problem, as it gets
302 more control over the stack handling -- but it should call setjmp
303 itself. I'd probably try something like:
305 // record top of stack for the GC
306 t->top = SCM_STACK_PTR (&t);
308 SCM_FLUSH_REGISTER_WINDOWS;
313 ... though even that's making some assumptions about the stack
314 ordering of local variables versus caller-saved registers.
316 For something like scm_leave_guile to work, I don't think it can just
317 rely on invalidated jump buffers. A valid jump buffer, and a handle
318 on the stack state at the point when the jump buffer was initialized,
319 together, would work fine, but I think then we're talking about macros
320 invoking setjmp in the caller's stack frame, and requiring that the
321 caller of scm_leave_guile also call scm_enter_guile before returning,
322 kind of like pthread_cleanup_push/pop calls that have to be paired up
323 in a function. (In fact, the pthread ones have to be paired up
324 syntactically, as if they might expand to a compound statement
325 incorporating the user's code, and invoking a compiler's
326 exception-handling primitives. Which might be something to think
327 about for cases where Guile is used with C++ exceptions or
331 scm_i_pthread_key_t scm_i_thread_key
;
334 resume (scm_i_thread
*t
)
337 if (t
->clear_freelists_p
)
339 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
340 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
341 t
->clear_freelists_p
= 0;
345 typedef void* scm_t_guile_ticket
;
348 scm_enter_guile (scm_t_guile_ticket ticket
)
350 scm_i_thread
*t
= (scm_i_thread
*)ticket
;
353 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
358 static scm_i_thread
*
361 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
363 /* record top of stack for the GC */
364 t
->top
= SCM_STACK_PTR (&t
);
365 /* save registers. */
366 SCM_FLUSH_REGISTER_WINDOWS
;
371 static scm_t_guile_ticket
374 scm_i_thread
*t
= suspend ();
375 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
376 return (scm_t_guile_ticket
) t
;
379 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
380 static scm_i_thread
*all_threads
= NULL
;
381 static int thread_count
;
383 static SCM scm_i_default_dynamic_state
;
385 /* Perform first stage of thread initialisation, in non-guile mode.
388 guilify_self_1 (SCM_STACKITEM
*base
)
390 scm_i_thread
*t
= malloc (sizeof (scm_i_thread
));
392 t
->pthread
= scm_i_pthread_self ();
393 t
->handle
= SCM_BOOL_F
;
394 t
->result
= SCM_BOOL_F
;
395 t
->join_queue
= SCM_EOL
;
396 t
->dynamic_state
= SCM_BOOL_F
;
397 t
->dynwinds
= SCM_EOL
;
398 t
->active_asyncs
= SCM_EOL
;
400 t
->pending_asyncs
= 1;
401 t
->last_debug_frame
= NULL
;
403 t
->continuation_root
= SCM_EOL
;
404 t
->continuation_base
= base
;
405 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
406 t
->sleep_mutex
= NULL
;
407 t
->sleep_object
= SCM_BOOL_F
;
409 /* XXX - check for errors. */
410 pipe (t
->sleep_pipe
);
411 scm_i_pthread_mutex_init (&t
->heap_mutex
, NULL
);
412 t
->clear_freelists_p
= 0;
416 t
->freelist
= SCM_EOL
;
417 t
->freelist2
= SCM_EOL
;
418 SCM_SET_FREELIST_LOC (scm_i_freelist
, &t
->freelist
);
419 SCM_SET_FREELIST_LOC (scm_i_freelist2
, &t
->freelist2
);
421 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
423 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
425 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
426 t
->next_thread
= all_threads
;
429 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
432 /* Perform second stage of thread initialisation, in guile mode.
435 guilify_self_2 (SCM parent
)
437 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
439 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
440 scm_gc_register_collectable_memory (t
, sizeof (scm_i_thread
), "thread");
441 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
442 t
->continuation_base
= t
->base
;
444 if (scm_is_true (parent
))
445 t
->dynamic_state
= scm_make_dynamic_state (parent
);
447 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
449 t
->join_queue
= make_queue ();
453 /* Perform thread tear-down, in guile mode.
456 do_thread_exit (void *v
)
458 scm_i_thread
*t
= (scm_i_thread
*)v
;
460 scm_i_scm_pthread_mutex_lock (&thread_admin_mutex
);
463 close (t
->sleep_pipe
[0]);
464 close (t
->sleep_pipe
[1]);
465 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
468 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
473 on_thread_exit (void *v
)
475 scm_i_thread
*t
= (scm_i_thread
*)v
, **tp
;
477 scm_i_pthread_setspecific (scm_i_thread_key
, v
);
479 /* Unblocking the joining threads needs to happen in guile mode
480 since the queue is a SCM data structure.
482 scm_with_guile (do_thread_exit
, v
);
484 /* Removing ourself from the list of all threads needs to happen in
485 non-guile mode since all SCM values on our stack become
486 unprotected once we are no longer in the list.
489 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
490 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
493 *tp
= t
->next_thread
;
497 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
499 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
502 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
505 init_thread_key (void)
507 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
510 /* Perform any initializations necessary to bring the current thread
511 into guile mode, initializing Guile itself, if necessary.
513 BASE is the stack base to use with GC.
515 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
516 which case the default dynamic state is used.
518 Return zero when the thread was in guile mode already; otherwise
523 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
527 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
529 if ((t
= SCM_I_CURRENT_THREAD
) == NULL
)
531 /* This thread has not been guilified yet.
534 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
535 if (scm_initialized_p
== 0)
537 /* First thread ever to enter Guile. Run the full
540 scm_i_init_guile (base
);
541 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
545 /* Guile is already initialized, but this thread enters it for
546 the first time. Only initialize this thread.
548 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
549 guilify_self_1 (base
);
550 guilify_self_2 (parent
);
556 /* This thread is already guilified but not in guile mode, just
559 XXX - base might be lower than when this thread was first
562 scm_enter_guile ((scm_t_guile_ticket
) t
);
567 /* Thread is already in guile mode. Nothing to do.
573 #if SCM_USE_PTHREAD_THREADS
574 /* pthread_getattr_np not available on MacOS X and Solaris 10. */
575 #if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
577 #define HAVE_GET_THREAD_STACK_BASE
579 static SCM_STACKITEM
*
580 get_thread_stack_base ()
586 pthread_getattr_np (pthread_self (), &attr
);
587 pthread_attr_getstack (&attr
, &start
, &size
);
588 end
= (char *)start
+ size
;
590 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
591 for the main thread, but we can use scm_get_stack_base in that
595 #ifndef PTHREAD_ATTR_GETSTACK_WORKS
596 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
597 return scm_get_stack_base ();
601 #if SCM_STACK_GROWS_UP
609 #endif /* HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP */
611 #else /* !SCM_USE_PTHREAD_THREADS */
613 #define HAVE_GET_THREAD_STACK_BASE
615 static SCM_STACKITEM
*
616 get_thread_stack_base ()
618 return scm_get_stack_base ();
621 #endif /* !SCM_USE_PTHREAD_THREADS */
623 #ifdef HAVE_GET_THREAD_STACK_BASE
628 scm_i_init_thread_for_guile (get_thread_stack_base (),
629 scm_i_default_dynamic_state
);
635 scm_with_guile (void *(*func
)(void *), void *data
)
637 return scm_i_with_guile_and_parent (func
, data
,
638 scm_i_default_dynamic_state
);
642 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
,
647 SCM_STACKITEM base_item
;
648 really_entered
= scm_i_init_thread_for_guile (&base_item
, parent
);
649 res
= scm_c_with_continuation_barrier (func
, data
);
656 scm_without_guile (void *(*func
)(void *), void *data
)
659 scm_t_guile_ticket t
;
660 t
= scm_leave_guile ();
666 /*** Thread creation */
673 scm_i_pthread_mutex_t mutex
;
674 scm_i_pthread_cond_t cond
;
678 really_launch (void *d
)
680 launch_data
*data
= (launch_data
*)d
;
681 SCM thunk
= data
->thunk
, handler
= data
->handler
;
684 t
= SCM_I_CURRENT_THREAD
;
686 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
687 data
->thread
= scm_current_thread ();
688 scm_i_pthread_cond_signal (&data
->cond
);
689 scm_i_pthread_mutex_unlock (&data
->mutex
);
691 if (SCM_UNBNDP (handler
))
692 t
->result
= scm_call_0 (thunk
);
694 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
700 launch_thread (void *d
)
702 launch_data
*data
= (launch_data
*)d
;
703 scm_i_pthread_detach (scm_i_pthread_self ());
704 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
708 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
709 (SCM thunk
, SCM handler
),
710 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
711 "returning a new thread object representing the thread. The procedure\n"
712 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
714 "When @var{handler} is specified, then @var{thunk} is called from\n"
715 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
716 "handler. This catch is established inside the continuation barrier.\n"
718 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
719 "the @emph{exit value} of the thread and the thread is terminated.")
720 #define FUNC_NAME s_scm_call_with_new_thread
726 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
727 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
728 handler
, SCM_ARG2
, FUNC_NAME
);
730 data
.parent
= scm_current_dynamic_state ();
732 data
.handler
= handler
;
733 data
.thread
= SCM_BOOL_F
;
734 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
735 scm_i_pthread_cond_init (&data
.cond
, NULL
);
737 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
738 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
741 scm_i_pthread_mutex_unlock (&data
.mutex
);
745 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
746 scm_i_pthread_mutex_unlock (&data
.mutex
);
754 scm_t_catch_body body
;
756 scm_t_catch_handler handler
;
759 scm_i_pthread_mutex_t mutex
;
760 scm_i_pthread_cond_t cond
;
764 really_spawn (void *d
)
766 spawn_data
*data
= (spawn_data
*)d
;
767 scm_t_catch_body body
= data
->body
;
768 void *body_data
= data
->body_data
;
769 scm_t_catch_handler handler
= data
->handler
;
770 void *handler_data
= data
->handler_data
;
771 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
773 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
774 data
->thread
= scm_current_thread ();
775 scm_i_pthread_cond_signal (&data
->cond
);
776 scm_i_pthread_mutex_unlock (&data
->mutex
);
779 t
->result
= body (body_data
);
781 t
->result
= scm_internal_catch (SCM_BOOL_T
,
783 handler
, handler_data
);
789 spawn_thread (void *d
)
791 spawn_data
*data
= (spawn_data
*)d
;
792 scm_i_pthread_detach (scm_i_pthread_self ());
793 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
798 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
799 scm_t_catch_handler handler
, void *handler_data
)
805 data
.parent
= scm_current_dynamic_state ();
807 data
.body_data
= body_data
;
808 data
.handler
= handler
;
809 data
.handler_data
= handler_data
;
810 data
.thread
= SCM_BOOL_F
;
811 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
812 scm_i_pthread_cond_init (&data
.cond
, NULL
);
814 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
815 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
818 scm_i_pthread_mutex_unlock (&data
.mutex
);
822 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
823 scm_i_pthread_mutex_unlock (&data
.mutex
);
828 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
830 "Move the calling thread to the end of the scheduling queue.")
831 #define FUNC_NAME s_scm_yield
833 return scm_from_bool (scm_i_sched_yield ());
837 SCM_DEFINE (scm_join_thread
, "join-thread", 1, 0, 0,
839 "Suspend execution of the calling thread until the target @var{thread} "
840 "terminates, unless the target @var{thread} has already terminated. ")
841 #define FUNC_NAME s_scm_join_thread
846 SCM_VALIDATE_THREAD (1, thread
);
847 if (scm_is_eq (scm_current_thread (), thread
))
848 SCM_MISC_ERROR ("can not join the current thread", SCM_EOL
);
850 scm_i_scm_pthread_mutex_lock (&thread_admin_mutex
);
852 t
= SCM_I_THREAD_DATA (thread
);
857 block_self (t
->join_queue
, thread
, &thread_admin_mutex
, NULL
);
860 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
862 scm_i_scm_pthread_mutex_lock (&thread_admin_mutex
);
867 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
874 /* We implement our own mutex type since we want them to be 'fair', we
875 want to do fancy things while waiting for them (like running
876 asyncs) and we might want to add things that are nice for
881 scm_i_pthread_mutex_t lock
;
883 int level
; /* how much the owner owns us.
884 < 0 for non-recursive mutexes */
885 SCM waiting
; /* the threads waiting for this mutex. */
888 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
889 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
892 fat_mutex_mark (SCM mx
)
894 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
895 scm_gc_mark (m
->owner
);
900 fat_mutex_free (SCM mx
)
902 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
903 scm_i_pthread_mutex_destroy (&m
->lock
);
904 scm_gc_free (m
, sizeof (fat_mutex
), "mutex");
909 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
911 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
912 scm_puts ("#<mutex ", port
);
913 scm_uintprint ((scm_t_bits
)m
, 16, port
);
914 scm_puts (">", port
);
919 make_fat_mutex (int recursive
)
924 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
925 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
926 m
->owner
= SCM_BOOL_F
;
927 m
->level
= recursive
? 0 : -1;
928 m
->waiting
= SCM_EOL
;
929 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
930 m
->waiting
= make_queue ();
934 SCM_DEFINE (scm_make_mutex
, "make-mutex", 0, 0, 0,
936 "Create a new mutex. ")
937 #define FUNC_NAME s_scm_make_mutex
939 return make_fat_mutex (0);
943 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
945 "Create a new recursive mutex. ")
946 #define FUNC_NAME s_scm_make_recursive_mutex
948 return make_fat_mutex (1);
953 fat_mutex_lock (SCM mutex
)
955 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
956 SCM thread
= scm_current_thread ();
959 scm_i_scm_pthread_mutex_lock (&m
->lock
);
960 if (scm_is_false (m
->owner
))
962 else if (scm_is_eq (m
->owner
, thread
))
967 msg
= "mutex already locked by current thread";
973 block_self (m
->waiting
, mutex
, &m
->lock
, NULL
);
974 if (scm_is_eq (m
->owner
, thread
))
976 scm_i_pthread_mutex_unlock (&m
->lock
);
978 scm_i_scm_pthread_mutex_lock (&m
->lock
);
981 scm_i_pthread_mutex_unlock (&m
->lock
);
985 SCM_DEFINE (scm_lock_mutex
, "lock-mutex", 1, 0, 0,
987 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
988 "blocks until the mutex becomes available. The function returns when "
989 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
990 "a thread already owns will succeed right away and will not block the "
991 "thread. That is, Guile's mutexes are @emph{recursive}. ")
992 #define FUNC_NAME s_scm_lock_mutex
996 SCM_VALIDATE_MUTEX (1, mx
);
997 msg
= fat_mutex_lock (mx
);
999 scm_misc_error (NULL
, msg
, SCM_EOL
);
1005 scm_dynwind_lock_mutex (SCM mutex
)
1007 scm_dynwind_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
1008 SCM_F_WIND_EXPLICITLY
);
1009 scm_dynwind_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
1010 SCM_F_WIND_EXPLICITLY
);
1014 fat_mutex_trylock (fat_mutex
*m
, int *resp
)
1017 SCM thread
= scm_current_thread ();
1020 scm_i_pthread_mutex_lock (&m
->lock
);
1021 if (scm_is_false (m
->owner
))
1023 else if (scm_is_eq (m
->owner
, thread
))
1028 msg
= "mutex already locked by current thread";
1032 scm_i_pthread_mutex_unlock (&m
->lock
);
1036 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1038 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1039 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1040 #define FUNC_NAME s_scm_try_mutex
1045 SCM_VALIDATE_MUTEX (1, mutex
);
1047 msg
= fat_mutex_trylock (SCM_MUTEX_DATA (mutex
), &res
);
1049 scm_misc_error (NULL
, msg
, SCM_EOL
);
1050 return scm_from_bool (res
);
1055 fat_mutex_unlock (fat_mutex
*m
)
1059 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1060 if (!scm_is_eq (m
->owner
, scm_current_thread ()))
1062 if (scm_is_false (m
->owner
))
1063 msg
= "mutex not locked";
1065 msg
= "mutex not locked by current thread";
1067 else if (m
->level
> 0)
1070 m
->owner
= unblock_from_queue (m
->waiting
);
1071 scm_i_pthread_mutex_unlock (&m
->lock
);
1076 SCM_DEFINE (scm_unlock_mutex
, "unlock-mutex", 1, 0, 0,
1078 "Unlocks @var{mutex} if the calling thread owns the lock on "
1079 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1080 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1081 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1082 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1083 "with a call to @code{unlock-mutex}. Only the last call to "
1084 "@code{unlock-mutex} will actually unlock the mutex. ")
1085 #define FUNC_NAME s_scm_unlock_mutex
1088 SCM_VALIDATE_MUTEX (1, mx
);
1090 msg
= fat_mutex_unlock (SCM_MUTEX_DATA (mx
));
1092 scm_misc_error (NULL
, msg
, SCM_EOL
);
1099 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1101 "Return the thread owning @var{mx}, or @code{#f}.")
1102 #define FUNC_NAME s_scm_mutex_owner
1104 SCM_VALIDATE_MUTEX (1, mx
);
1105 return (SCM_MUTEX_DATA(mx
))->owner
;
1109 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1111 "Return the lock level of a recursive mutex, or -1\n"
1112 "for a standard mutex.")
1113 #define FUNC_NAME s_scm_mutex_level
1115 SCM_VALIDATE_MUTEX (1, mx
);
1116 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1122 /*** Fat condition variables */
1125 scm_i_pthread_mutex_t lock
;
1126 SCM waiting
; /* the threads waiting for this condition. */
1129 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1130 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1133 fat_cond_mark (SCM cv
)
1135 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1140 fat_cond_free (SCM mx
)
1142 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1143 scm_i_pthread_mutex_destroy (&c
->lock
);
1144 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1149 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1151 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1152 scm_puts ("#<condition-variable ", port
);
1153 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1154 scm_puts (">", port
);
1158 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1160 "Make a new condition variable.")
1161 #define FUNC_NAME s_scm_make_condition_variable
1166 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1167 scm_i_pthread_mutex_init (&c
->lock
, 0);
1168 c
->waiting
= SCM_EOL
;
1169 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1170 c
->waiting
= make_queue ();
1176 fat_cond_timedwait (SCM cond
, SCM mutex
,
1177 const scm_t_timespec
*waittime
)
1179 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1180 fat_cond
*c
= SCM_CONDVAR_DATA (cond
);
1181 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1187 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1188 msg
= fat_mutex_unlock (m
);
1192 err
= block_self (c
->waiting
, cond
, &c
->lock
, waittime
);
1193 scm_i_pthread_mutex_unlock (&c
->lock
);
1194 fat_mutex_lock (mutex
);
1197 scm_i_pthread_mutex_unlock (&c
->lock
);
1202 scm_misc_error (NULL
, msg
, SCM_EOL
);
1204 scm_remember_upto_here_2 (cond
, mutex
);
1208 if (err
== ETIMEDOUT
)
1213 scm_syserror (NULL
);
1218 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1219 (SCM cv
, SCM mx
, SCM t
),
1220 "Wait until @var{cond-var} has been signalled. While waiting, "
1221 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1222 "is locked again when this function returns. When @var{time} is given, "
1223 "it specifies a point in time where the waiting should be aborted. It "
1224 "can be either a integer as returned by @code{current-time} or a pair "
1225 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1226 "mutex is locked and @code{#f} is returned. When the condition "
1227 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1229 #define FUNC_NAME s_scm_timed_wait_condition_variable
1231 scm_t_timespec waittime
, *waitptr
= NULL
;
1233 SCM_VALIDATE_CONDVAR (1, cv
);
1234 SCM_VALIDATE_MUTEX (2, mx
);
1236 if (!SCM_UNBNDP (t
))
1238 if (scm_is_pair (t
))
1240 waittime
.tv_sec
= scm_to_ulong (SCM_CAR (t
));
1241 waittime
.tv_nsec
= scm_to_ulong (SCM_CAR (t
)) * 1000;
1245 waittime
.tv_sec
= scm_to_ulong (t
);
1246 waittime
.tv_nsec
= 0;
1248 waitptr
= &waittime
;
1251 return scm_from_bool (fat_cond_timedwait (cv
, mx
, waitptr
));
1256 fat_cond_signal (fat_cond
*c
)
1258 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1259 unblock_from_queue (c
->waiting
);
1260 scm_i_pthread_mutex_unlock (&c
->lock
);
1263 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1265 "Wake up one thread that is waiting for @var{cv}")
1266 #define FUNC_NAME s_scm_signal_condition_variable
1268 SCM_VALIDATE_CONDVAR (1, cv
);
1269 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1275 fat_cond_broadcast (fat_cond
*c
)
1277 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1278 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1280 scm_i_pthread_mutex_unlock (&c
->lock
);
1283 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1285 "Wake up all threads that are waiting for @var{cv}. ")
1286 #define FUNC_NAME s_scm_broadcast_condition_variable
1288 SCM_VALIDATE_CONDVAR (1, cv
);
1289 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1294 /*** Marking stacks */
1296 /* XXX - what to do with this? Do we need to handle this for blocked
1300 # define SCM_MARK_BACKING_STORE() do { \
1302 SCM_STACKITEM * top, * bot; \
1303 getcontext (&ctx); \
1304 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1305 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1306 / sizeof (SCM_STACKITEM))); \
1307 bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
1308 top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
1309 scm_mark_locations (bot, top - bot); } while (0)
1311 # define SCM_MARK_BACKING_STORE()
1315 scm_threads_mark_stacks (void)
1318 for (t
= all_threads
; t
; t
= t
->next_thread
)
1320 /* Check that thread has indeed been suspended.
1324 scm_gc_mark (t
->handle
);
1326 #if SCM_STACK_GROWS_UP
1327 scm_mark_locations (t
->base
, t
->top
- t
->base
);
1329 scm_mark_locations (t
->top
, t
->base
- t
->top
);
1331 scm_mark_locations ((SCM_STACKITEM
*) t
->regs
,
1332 ((size_t) sizeof(t
->regs
)
1333 / sizeof (SCM_STACKITEM
)));
1336 SCM_MARK_BACKING_STORE ();
1342 scm_std_select (int nfds
,
1343 SELECT_TYPE
*readfds
,
1344 SELECT_TYPE
*writefds
,
1345 SELECT_TYPE
*exceptfds
,
1346 struct timeval
*timeout
)
1349 int res
, eno
, wakeup_fd
;
1350 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1351 scm_t_guile_ticket ticket
;
1353 if (readfds
== NULL
)
1355 FD_ZERO (&my_readfds
);
1356 readfds
= &my_readfds
;
1359 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1362 wakeup_fd
= t
->sleep_pipe
[0];
1363 ticket
= scm_leave_guile ();
1364 FD_SET (wakeup_fd
, readfds
);
1365 if (wakeup_fd
>= nfds
)
1367 res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1370 scm_enter_guile (ticket
);
1372 scm_i_reset_sleep (t
);
1374 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1377 read (wakeup_fd
, &dummy
, 1);
1378 FD_CLR (wakeup_fd
, readfds
);
1390 /* Convenience API for blocking while in guile mode. */
1392 #if SCM_USE_PTHREAD_THREADS
1395 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1397 scm_t_guile_ticket t
= scm_leave_guile ();
1398 int res
= scm_i_pthread_mutex_lock (mutex
);
1399 scm_enter_guile (t
);
1404 do_unlock (void *data
)
1406 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1410 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1412 scm_i_scm_pthread_mutex_lock (mutex
);
1413 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1417 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1419 scm_t_guile_ticket t
= scm_leave_guile ();
1420 int res
= scm_i_pthread_cond_wait (cond
, mutex
);
1421 scm_enter_guile (t
);
1426 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1427 scm_i_pthread_mutex_t
*mutex
,
1428 const scm_t_timespec
*wt
)
1430 scm_t_guile_ticket t
= scm_leave_guile ();
1431 int res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1432 scm_enter_guile (t
);
1439 scm_std_usleep (unsigned long usecs
)
1442 tv
.tv_usec
= usecs
% 1000000;
1443 tv
.tv_sec
= usecs
/ 1000000;
1444 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1445 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1449 scm_std_sleep (unsigned int secs
)
1454 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1460 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1462 "Return the thread that called this function.")
1463 #define FUNC_NAME s_scm_current_thread
1465 return SCM_I_CURRENT_THREAD
->handle
;
1470 scm_c_make_list (size_t n
, SCM fill
)
1474 res
= scm_cons (fill
, res
);
1478 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1480 "Return a list of all threads.")
1481 #define FUNC_NAME s_scm_all_threads
1483 /* We can not allocate while holding the thread_admin_mutex because
1484 of the way GC is done.
1486 int n
= thread_count
;
1488 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1490 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1492 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1494 SCM_SETCAR (*l
, t
->handle
);
1495 l
= SCM_CDRLOC (*l
);
1499 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1504 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1506 "Return @code{#t} iff @var{thread} has exited.\n")
1507 #define FUNC_NAME s_scm_thread_exited_p
1509 return scm_from_bool (scm_c_thread_exited_p (thread
));
1514 scm_c_thread_exited_p (SCM thread
)
1515 #define FUNC_NAME s_scm_thread_exited_p
1518 SCM_VALIDATE_THREAD (1, thread
);
1519 t
= SCM_I_THREAD_DATA (thread
);
1524 static scm_i_pthread_cond_t wake_up_cond
;
1525 int scm_i_thread_go_to_sleep
;
1526 static int threads_initialized_p
= 0;
1529 scm_i_thread_put_to_sleep ()
1531 if (threads_initialized_p
)
1536 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1538 /* Signal all threads to go to sleep
1540 scm_i_thread_go_to_sleep
= 1;
1541 for (t
= all_threads
; t
; t
= t
->next_thread
)
1542 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
1543 scm_i_thread_go_to_sleep
= 0;
1548 scm_i_thread_invalidate_freelists ()
1550 /* thread_admin_mutex is already locked. */
1553 for (t
= all_threads
; t
; t
= t
->next_thread
)
1554 if (t
!= SCM_I_CURRENT_THREAD
)
1555 t
->clear_freelists_p
= 1;
1559 scm_i_thread_wake_up ()
1561 if (threads_initialized_p
)
1565 scm_i_pthread_cond_broadcast (&wake_up_cond
);
1566 for (t
= all_threads
; t
; t
= t
->next_thread
)
1567 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
1568 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1569 scm_enter_guile ((scm_t_guile_ticket
) SCM_I_CURRENT_THREAD
);
1574 scm_i_thread_sleep_for_gc ()
1576 scm_i_thread
*t
= suspend ();
1577 scm_i_pthread_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1581 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
1583 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
1584 int scm_i_critical_section_level
= 0;
1586 static SCM dynwind_critical_section_mutex
;
1589 scm_dynwind_critical_section (SCM mutex
)
1591 if (scm_is_false (mutex
))
1592 mutex
= dynwind_critical_section_mutex
;
1593 scm_dynwind_lock_mutex (mutex
);
1594 scm_dynwind_block_asyncs ();
1597 /*** Initialization */
1599 scm_i_pthread_key_t scm_i_freelist
, scm_i_freelist2
;
1600 scm_i_pthread_mutex_t scm_i_misc_mutex
;
1602 #if SCM_USE_PTHREAD_THREADS
1603 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
1607 scm_threads_prehistory (SCM_STACKITEM
*base
)
1609 #if SCM_USE_PTHREAD_THREADS
1610 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
1611 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
1612 PTHREAD_MUTEX_RECURSIVE
);
1615 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
1616 scm_i_pthread_mutexattr_recursive
);
1617 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
1618 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
1619 scm_i_pthread_key_create (&scm_i_freelist
, NULL
);
1620 scm_i_pthread_key_create (&scm_i_freelist2
, NULL
);
1622 guilify_self_1 (base
);
1625 scm_t_bits scm_tc16_thread
;
1626 scm_t_bits scm_tc16_mutex
;
1627 scm_t_bits scm_tc16_condvar
;
1632 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
1633 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
1634 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1635 scm_set_smob_free (scm_tc16_thread
, thread_free
);
1637 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
1638 scm_set_smob_mark (scm_tc16_mutex
, fat_mutex_mark
);
1639 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
1640 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
1642 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1644 scm_set_smob_mark (scm_tc16_condvar
, fat_cond_mark
);
1645 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
1646 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
1648 scm_i_default_dynamic_state
= SCM_BOOL_F
;
1649 guilify_self_2 (SCM_BOOL_F
);
1650 threads_initialized_p
= 1;
1652 dynwind_critical_section_mutex
=
1653 scm_permanent_object (scm_make_recursive_mutex ());
1657 scm_init_threads_default_dynamic_state ()
1659 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
1660 scm_i_default_dynamic_state
= scm_permanent_object (state
);
1664 scm_init_thread_procs ()
1666 #include "libguile/threads.x"