| 1 | /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2002 Free Software Foundation, Inc. |
| 2 | * |
| 3 | * This program is free software; you can redistribute it and/or modify |
| 4 | * it under the terms of the GNU General Public License as published by |
| 5 | * the Free Software Foundation; either version 2, or (at your option) |
| 6 | * any later version. |
| 7 | * |
| 8 | * This program is distributed in the hope that it will be useful, |
| 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 11 | * GNU General Public License for more details. |
| 12 | * |
| 13 | * You should have received a copy of the GNU General Public License |
| 14 | * along with this software; see the file COPYING. If not, write to |
| 15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
| 16 | * Boston, MA 02111-1307 USA |
| 17 | * |
| 18 | * As a special exception, the Free Software Foundation gives permission |
| 19 | * for additional uses of the text contained in its release of GUILE. |
| 20 | * |
| 21 | * The exception is that, if you link the GUILE library with other files |
| 22 | * to produce an executable, this does not by itself cause the |
| 23 | * resulting executable to be covered by the GNU General Public License. |
| 24 | * Your use of that executable is in no way restricted on account of |
| 25 | * linking the GUILE library code into it. |
| 26 | * |
| 27 | * This exception does not however invalidate any other reasons why |
| 28 | * the executable file might be covered by the GNU General Public License. |
| 29 | * |
| 30 | * This exception applies only to the code released by the |
| 31 | * Free Software Foundation under the name GUILE. If you copy |
| 32 | * code from other Free Software Foundation releases into a copy of |
| 33 | * GUILE, as the General Public License permits, the exception does |
| 34 | * not apply to the code that you add in this way. To avoid misleading |
| 35 | * anyone as to the status of such modified files, you must delete |
| 36 | * this exception notice from them. |
| 37 | * |
| 38 | * If you write modifications of your own for GUILE, it is your choice |
| 39 | * whether to permit this exception to apply to your modifications. |
| 40 | * If you do not wish that, delete this exception notice. */ |
| 41 | |
| 42 | |
| 43 | \f |
| 44 | |
| 45 | /* This file does some pretty hairy #inclusion. It probably seemed |
| 46 | like a good idea at the time, but it doesn't now. Here's the |
| 47 | structure, edited for relevance (!), last I checked: |
| 48 | |
| 49 | threads.c: |
| 50 | threads.h |
| 51 | coop-defs.h |
| 52 | iselect.h |
| 53 | coop-threads.c |
| 54 | coop-threads.h |
| 55 | coop-defs.h* |
| 56 | ../qt/qt.h |
| 57 | coop.c |
| 58 | <qt.h> |
| 59 | |
| 60 | * second #inclusion |
| 61 | */ |
| 62 | |
| 63 | #include <errno.h> |
| 64 | |
| 65 | #include "libguile/_scm.h" |
| 66 | #include "libguile/dynwind.h" |
| 67 | #include "libguile/smob.h" |
| 68 | |
| 69 | #include "libguile/threads.h" |
| 70 | |
| 71 | \f |
| 72 | |
| 73 | scm_t_bits scm_tc16_thread; |
| 74 | scm_t_bits scm_tc16_mutex; |
| 75 | scm_t_bits scm_tc16_condvar; |
| 76 | |
| 77 | \f |
| 78 | /* Scheme-visible thread functions. */ |
| 79 | |
| 80 | #ifdef USE_COOP_THREADS |
| 81 | SCM_REGISTER_PROC(s_single_thread_p, "single-active-thread?", 0, 0, 0, scm_single_thread_p); |
| 82 | #endif |
| 83 | |
| 84 | /* GJB:FIXME:DOC: SCM_REGISTER_PROC needs to permit a docstring, |
| 85 | or these need to move into the file where the proc is defined. */ |
| 86 | |
| 87 | SCM_REGISTER_PROC(s_yield, "yield", 0, 0, 0, scm_yield); |
| 88 | /* If one or more threads are waiting to execute, calling yield forces an |
| 89 | immediate context switch to one of them. Otherwise, yield has no effect. |
| 90 | */ |
| 91 | |
| 92 | SCM_REGISTER_PROC(s_call_with_new_thread, "call-with-new-thread", 0, 0, 1, scm_call_with_new_thread); |
| 93 | /* Evaluate @var{(thunk)} in a new thread, and new dynamic context, |
| 94 | returning a new thread object representing the thread. |
| 95 | |
| 96 | If an error occurs during evaluation, call error-thunk, passing it an |
| 97 | error code describing the condition. [Error codes are currently |
| 98 | meaningless integers. In the future, real values will be specified.] |
| 99 | If this happens, the error-thunk is called outside the scope of the new |
| 100 | root -- it is called in the same dynamic context in which |
| 101 | with-new-thread was evaluated, but not in the callers thread. |
| 102 | |
| 103 | All the evaluation rules for dynamic roots apply to threads. |
| 104 | */ |
| 105 | |
| 106 | SCM_REGISTER_PROC(s_current_thread, "current-thread", 0, 0, 0, scm_current_thread); |
| 107 | SCM_REGISTER_PROC(s_all_thread, "all-threads", 0, 0, 0, scm_all_threads); |
| 108 | |
| 109 | SCM_REGISTER_PROC(s_join_thread, "join-thread", 1, 0, 0, scm_join_thread); |
| 110 | /* Suspend execution of the calling thread until the target @var{thread} |
| 111 | terminates, unless the target @var{thread} has already terminated. |
| 112 | */ |
| 113 | |
| 114 | SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0, |
| 115 | (SCM thread), |
| 116 | "Return @code{#t} iff @var{thread} has exited.\n") |
| 117 | #define FUNC_NAME s_scm_thread_exited_p |
| 118 | { |
| 119 | return SCM_BOOL (scm_c_thread_exited_p (thread)); |
| 120 | } |
| 121 | #undef FUNC_NAME |
| 122 | |
| 123 | SCM_REGISTER_PROC(s_make_mutex, "make-mutex", 0, 0, 0, scm_make_mutex); |
| 124 | /* Create a new mutex object. */ |
| 125 | |
| 126 | SCM_REGISTER_PROC(s_lock_mutex, "lock-mutex", 1, 0, 0, scm_lock_mutex); |
| 127 | /* Lock @var{mutex}. If the mutex is already locked, the calling thread |
| 128 | blocks until the mutex becomes available. The function returns when |
| 129 | the calling thread owns the lock on @var{mutex}. */ |
| 130 | |
| 131 | SCM_REGISTER_PROC(s_try_mutex, "try-mutex", 1, 0, 0, scm_try_mutex); |
| 132 | /* Try to lock @var{mutex}. If the mutex is already locked by someone |
| 133 | else, return @code{#f}. Else lock the mutex and return @code{#t}. */ |
| 134 | |
| 135 | SCM_REGISTER_PROC(s_unlock_mutex, "unlock-mutex", 1, 0, 0, scm_unlock_mutex); |
| 136 | /* Unlocks @var{mutex} if the calling thread owns the lock on @var{mutex}. |
| 137 | Calling unlock-mutex on a mutex not owned by the current thread results |
| 138 | in undefined behaviour. Once a mutex has been unlocked, one thread |
| 139 | blocked on @var{mutex} is awakened and grabs the mutex lock. */ |
| 140 | |
| 141 | SCM_REGISTER_PROC(s_make_condition_variable, "make-condition-variable", 0, 0, 0, scm_make_condition_variable); |
| 142 | |
| 143 | SCM_REGISTER_PROC(s_wait_condition_variable, "wait-condition-variable", 2, 1, 0, scm_timed_wait_condition_variable); |
| 144 | |
| 145 | SCM_REGISTER_PROC(s_signal_condition_variable, "signal-condition-variable", 1, 0, 0, scm_signal_condition_variable); |
| 146 | |
| 147 | SCM_REGISTER_PROC(s_broadcast_condition_variable, "broadcast-condition-variable", 1, 0, 0, scm_broadcast_condition_variable); |
| 148 | |
| 149 | SCM |
| 150 | scm_wait_condition_variable (SCM c, SCM m) |
| 151 | { |
| 152 | return scm_timed_wait_condition_variable (c, m, SCM_UNDEFINED); |
| 153 | } |
| 154 | |
| 155 | \f |
| 156 | |
| 157 | #ifdef USE_COOP_THREADS |
| 158 | #include "libguile/coop-threads.c" |
| 159 | #else |
| 160 | #ifdef USE_COPT_THREADS |
| 161 | #include "libguile/coop-pthreads.c" |
| 162 | #else |
| 163 | #include "libguile/null-threads.c" |
| 164 | #endif |
| 165 | #endif |
| 166 | |
| 167 | \f |
| 168 | |
| 169 | #if (SCM_ENABLE_DEPRECATED == 1) |
| 170 | |
| 171 | SCM_API int |
| 172 | scm_mutex_init (scm_t_mutex *m) |
| 173 | { |
| 174 | scm_gc_protect_object (m->m = scm_make_mutex ()); |
| 175 | return 0; |
| 176 | } |
| 177 | |
| 178 | SCM_API int |
| 179 | scm_mutex_lock (scm_t_mutex *m) |
| 180 | { |
| 181 | scm_lock_mutex (m->m); |
| 182 | return 0; |
| 183 | } |
| 184 | |
| 185 | SCM_API int |
| 186 | scm_mutex_trylock (scm_t_mutex *m) |
| 187 | { |
| 188 | return SCM_FALSEP (scm_try_mutex (m->m))? EBUSY : 0; |
| 189 | } |
| 190 | |
| 191 | SCM_API int |
| 192 | scm_mutex_unlock (scm_t_mutex *m) |
| 193 | { |
| 194 | scm_unlock_mutex (m->m); |
| 195 | return 0; |
| 196 | } |
| 197 | |
| 198 | SCM_API int |
| 199 | scm_mutex_destroy (scm_t_mutex *m) |
| 200 | { |
| 201 | scm_gc_unprotect_object (m->m); |
| 202 | return 0; |
| 203 | } |
| 204 | |
| 205 | SCM_API int |
| 206 | scm_cond_init (scm_t_cond *c, int *cattr) |
| 207 | { |
| 208 | scm_gc_protect_object (c->c = scm_make_condition_variable ()); |
| 209 | return 0; |
| 210 | } |
| 211 | |
| 212 | SCM_API int |
| 213 | scm_cond_wait (scm_t_cond *c, scm_t_mutex *m) |
| 214 | { |
| 215 | scm_wait_condition_variable (c->c, m->m); |
| 216 | return 0; |
| 217 | } |
| 218 | |
| 219 | SCM_API int |
| 220 | scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m, |
| 221 | const struct timespec *t) |
| 222 | { |
| 223 | return !SCM_FALSEP (scm_timed_wait_condition_variable ( |
| 224 | c->c, m->m, scm_cons (scm_long2num (t->tv_sec), |
| 225 | scm_long2num (t->tv_nsec/1000)))); |
| 226 | } |
| 227 | |
| 228 | SCM_API int |
| 229 | scm_cond_signal (scm_t_cond *c) |
| 230 | { |
| 231 | scm_signal_condition_variable (c->c); |
| 232 | return 0; |
| 233 | } |
| 234 | |
| 235 | SCM_API int |
| 236 | scm_cond_broadcast (scm_t_cond *c) |
| 237 | { |
| 238 | scm_broadcast_condition_variable (c->c); |
| 239 | return 0; |
| 240 | } |
| 241 | |
| 242 | SCM_API int |
| 243 | scm_cond_destroy (scm_t_cond *c) |
| 244 | { |
| 245 | scm_gc_unprotect_object (c->c); |
| 246 | return 0; |
| 247 | } |
| 248 | |
| 249 | #endif |
| 250 | |
| 251 | \f |
| 252 | |
| 253 | void |
| 254 | scm_init_threads (SCM_STACKITEM *i) |
| 255 | { |
| 256 | /* Initialize implementation specific details of the threads support */ |
| 257 | scm_threads_init (i); |
| 258 | } |
| 259 | |
| 260 | void |
| 261 | scm_init_thread_procs () |
| 262 | { |
| 263 | #include "libguile/threads.x" |
| 264 | } |
| 265 | |
| 266 | /* |
| 267 | Local Variables: |
| 268 | c-file-style: "gnu" |
| 269 | End: |
| 270 | */ |