| 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, |
| 2 | * 2009, 2010, 2011, 2014 Free Software Foundation, Inc. |
| 3 | * |
| 4 | * This library is free software; you can redistribute it and/or |
| 5 | * modify it under the terms of the GNU Lesser General Public License |
| 6 | * as published by the Free Software Foundation; either version 3 of |
| 7 | * the License, or (at your option) any later version. |
| 8 | * |
| 9 | * This library is distributed in the hope that it will be useful, but |
| 10 | * WITHOUT ANY WARRANTY; without even the implied warranty of |
| 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 12 | * Lesser General Public License for more details. |
| 13 | * |
| 14 | * You should have received a copy of the GNU Lesser General Public |
| 15 | * License along with this library; if not, write to the Free Software |
| 16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
| 17 | * 02110-1301 USA |
| 18 | */ |
| 19 | |
| 20 | |
| 21 | \f |
| 22 | #ifdef HAVE_CONFIG_H |
| 23 | # include <config.h> |
| 24 | #endif |
| 25 | |
| 26 | #include "libguile/_scm.h" |
| 27 | #include "libguile/eval.h" |
| 28 | #include "libguile/throw.h" |
| 29 | #include "libguile/root.h" |
| 30 | #include "libguile/smob.h" |
| 31 | #include "libguile/dynwind.h" |
| 32 | #include "libguile/deprecation.h" |
| 33 | |
| 34 | #include "libguile/validate.h" |
| 35 | #include "libguile/async.h" |
| 36 | |
| 37 | #ifdef HAVE_STRING_H |
| 38 | #include <string.h> |
| 39 | #endif |
| 40 | #include <unistd.h> |
| 41 | |
| 42 | #include <full-write.h> |
| 43 | |
| 44 | \f |
| 45 | /* {Asynchronous Events} |
| 46 | * |
| 47 | * There are two kinds of asyncs: system asyncs and user asyncs. The |
| 48 | * two kinds have some concepts in commen but work slightly |
| 49 | * differently and are not interchangeable. |
| 50 | * |
| 51 | * System asyncs are used to run arbitrary code at the next safe point |
| 52 | * in a specified thread. You can use them to trigger execution of |
| 53 | * Scheme code from signal handlers or to interrupt a thread, for |
| 54 | * example. |
| 55 | * |
| 56 | * Each thread has a list of 'activated asyncs', which is a normal |
| 57 | * Scheme list of procedures with zero arguments. When a thread |
| 58 | * executes a SCM_ASYNC_TICK statement (which is included in |
| 59 | * SCM_TICK), it will call all procedures on this list. |
| 60 | * |
| 61 | * Also, a thread will wake up when a procedure is added to its list |
| 62 | * of active asyncs and call them. After that, it will go to sleep |
| 63 | * again. (Not implemented yet.) |
| 64 | * |
| 65 | * |
| 66 | * User asyncs are a little data structure that consists of a |
| 67 | * procedure of zero arguments and a mark. There are functions for |
| 68 | * setting the mark of a user async and for calling all procedures of |
| 69 | * marked asyncs in a given list. Nothing you couldn't quickly |
| 70 | * implement yourself. |
| 71 | */ |
| 72 | |
| 73 | |
| 74 | \f |
| 75 | |
| 76 | /* User asyncs. */ |
| 77 | |
| 78 | static scm_t_bits tc16_async; |
| 79 | |
| 80 | /* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it. |
| 81 | this is ugly. */ |
| 82 | #define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X) |
| 83 | #define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async") |
| 84 | |
| 85 | #define ASYNC_GOT_IT(X) (SCM_SMOB_FLAGS (X)) |
| 86 | #define SET_ASYNC_GOT_IT(X, V) (SCM_SET_SMOB_FLAGS ((X), ((V)))) |
| 87 | #define ASYNC_THUNK(X) SCM_SMOB_OBJECT_1 (X) |
| 88 | |
| 89 | |
| 90 | SCM_DEFINE (scm_async, "async", 1, 0, 0, |
| 91 | (SCM thunk), |
| 92 | "Create a new async for the procedure @var{thunk}.") |
| 93 | #define FUNC_NAME s_scm_async |
| 94 | { |
| 95 | SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk)); |
| 96 | } |
| 97 | #undef FUNC_NAME |
| 98 | |
| 99 | SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0, |
| 100 | (SCM a), |
| 101 | "Mark the async @var{a} for future execution.") |
| 102 | #define FUNC_NAME s_scm_async_mark |
| 103 | { |
| 104 | VALIDATE_ASYNC (1, a); |
| 105 | SET_ASYNC_GOT_IT (a, 1); |
| 106 | return SCM_UNSPECIFIED; |
| 107 | } |
| 108 | #undef FUNC_NAME |
| 109 | |
| 110 | SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, |
| 111 | (SCM list_of_a), |
| 112 | "Execute all thunks from the asyncs of the list @var{list_of_a}.") |
| 113 | #define FUNC_NAME s_scm_run_asyncs |
| 114 | { |
| 115 | while (! SCM_NULL_OR_NIL_P (list_of_a)) |
| 116 | { |
| 117 | SCM a; |
| 118 | SCM_VALIDATE_CONS (1, list_of_a); |
| 119 | a = SCM_CAR (list_of_a); |
| 120 | VALIDATE_ASYNC (SCM_ARG1, a); |
| 121 | if (ASYNC_GOT_IT (a)) |
| 122 | { |
| 123 | SET_ASYNC_GOT_IT (a, 0); |
| 124 | scm_call_0 (ASYNC_THUNK (a)); |
| 125 | } |
| 126 | list_of_a = SCM_CDR (list_of_a); |
| 127 | } |
| 128 | return SCM_BOOL_T; |
| 129 | } |
| 130 | #undef FUNC_NAME |
| 131 | |
| 132 | \f |
| 133 | |
| 134 | static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; |
| 135 | |
| 136 | /* System asyncs. */ |
| 137 | |
| 138 | void |
| 139 | scm_async_tick (void) |
| 140 | { |
| 141 | scm_i_thread *t = SCM_I_CURRENT_THREAD; |
| 142 | SCM asyncs; |
| 143 | |
| 144 | /* Reset pending_asyncs even when asyncs are blocked and not really |
| 145 | executed since this will avoid future futile calls to this |
| 146 | function. When asyncs are unblocked again, this function is |
| 147 | invoked even when pending_asyncs is zero. |
| 148 | */ |
| 149 | |
| 150 | scm_i_scm_pthread_mutex_lock (&async_mutex); |
| 151 | t->pending_asyncs = 0; |
| 152 | if (t->block_asyncs == 0) |
| 153 | { |
| 154 | asyncs = t->active_asyncs; |
| 155 | t->active_asyncs = SCM_EOL; |
| 156 | } |
| 157 | else |
| 158 | asyncs = SCM_EOL; |
| 159 | scm_i_pthread_mutex_unlock (&async_mutex); |
| 160 | |
| 161 | while (scm_is_pair (asyncs)) |
| 162 | { |
| 163 | SCM next = SCM_CDR (asyncs); |
| 164 | SCM_SETCDR (asyncs, SCM_BOOL_F); |
| 165 | scm_call_0 (SCM_CAR (asyncs)); |
| 166 | asyncs = next; |
| 167 | } |
| 168 | } |
| 169 | |
| 170 | void |
| 171 | scm_i_queue_async_cell (SCM c, scm_i_thread *t) |
| 172 | { |
| 173 | SCM sleep_object; |
| 174 | scm_i_pthread_mutex_t *sleep_mutex; |
| 175 | int sleep_fd; |
| 176 | SCM p; |
| 177 | |
| 178 | scm_i_scm_pthread_mutex_lock (&async_mutex); |
| 179 | p = t->active_asyncs; |
| 180 | SCM_SETCDR (c, SCM_EOL); |
| 181 | if (!scm_is_pair (p)) |
| 182 | t->active_asyncs = c; |
| 183 | else |
| 184 | { |
| 185 | SCM pp; |
| 186 | while (scm_is_pair (pp = SCM_CDR (p))) |
| 187 | { |
| 188 | if (scm_is_eq (SCM_CAR (p), SCM_CAR (c))) |
| 189 | { |
| 190 | scm_i_pthread_mutex_unlock (&async_mutex); |
| 191 | return; |
| 192 | } |
| 193 | p = pp; |
| 194 | } |
| 195 | SCM_SETCDR (p, c); |
| 196 | } |
| 197 | t->pending_asyncs = 1; |
| 198 | sleep_object = t->sleep_object; |
| 199 | sleep_mutex = t->sleep_mutex; |
| 200 | sleep_fd = t->sleep_fd; |
| 201 | scm_i_pthread_mutex_unlock (&async_mutex); |
| 202 | |
| 203 | if (sleep_mutex) |
| 204 | { |
| 205 | /* By now, the thread T might be out of its sleep already, or |
| 206 | might even be in the next, unrelated sleep. Interrupting it |
| 207 | anyway does no harm, however. |
| 208 | |
| 209 | The important thing to prevent here is to signal sleep_cond |
| 210 | before T waits on it. This can not happen since T has |
| 211 | sleep_mutex locked while setting t->sleep_mutex and will only |
| 212 | unlock it again while waiting on sleep_cond. |
| 213 | */ |
| 214 | scm_i_scm_pthread_mutex_lock (sleep_mutex); |
| 215 | scm_i_pthread_cond_signal (&t->sleep_cond); |
| 216 | scm_i_pthread_mutex_unlock (sleep_mutex); |
| 217 | } |
| 218 | |
| 219 | if (sleep_fd >= 0) |
| 220 | { |
| 221 | char dummy = 0; |
| 222 | |
| 223 | /* Likewise, T might already been done with sleeping here, but |
| 224 | interrupting it once too often does no harm. T might also |
| 225 | not yet have started sleeping, but this is no problem either |
| 226 | since the data written to a pipe will not be lost, unlike a |
| 227 | condition variable signal. */ |
| 228 | full_write (sleep_fd, &dummy, 1); |
| 229 | } |
| 230 | |
| 231 | /* This is needed to protect sleep_mutex. |
| 232 | */ |
| 233 | scm_remember_upto_here_1 (sleep_object); |
| 234 | } |
| 235 | |
| 236 | int |
| 237 | scm_i_setup_sleep (scm_i_thread *t, |
| 238 | SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex, |
| 239 | int sleep_fd) |
| 240 | { |
| 241 | int pending; |
| 242 | |
| 243 | scm_i_scm_pthread_mutex_lock (&async_mutex); |
| 244 | pending = t->pending_asyncs; |
| 245 | if (!pending) |
| 246 | { |
| 247 | t->sleep_object = sleep_object; |
| 248 | t->sleep_mutex = sleep_mutex; |
| 249 | t->sleep_fd = sleep_fd; |
| 250 | } |
| 251 | scm_i_pthread_mutex_unlock (&async_mutex); |
| 252 | return pending; |
| 253 | } |
| 254 | |
| 255 | void |
| 256 | scm_i_reset_sleep (scm_i_thread *t) |
| 257 | { |
| 258 | scm_i_scm_pthread_mutex_lock (&async_mutex); |
| 259 | t->sleep_object = SCM_BOOL_F; |
| 260 | t->sleep_mutex = NULL; |
| 261 | t->sleep_fd = -1; |
| 262 | scm_i_pthread_mutex_unlock (&async_mutex); |
| 263 | } |
| 264 | |
| 265 | SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, |
| 266 | (SCM proc, SCM thread), |
| 267 | "Mark @var{proc} (a procedure with zero arguments) for future execution\n" |
| 268 | "in @var{thread}. If @var{proc} has already been marked for\n" |
| 269 | "@var{thread} but has not been executed yet, this call has no effect.\n" |
| 270 | "If @var{thread} is omitted, the thread that called\n" |
| 271 | "@code{system-async-mark} is used.\n\n" |
| 272 | "This procedure is not safe to be called from C signal handlers. Use\n" |
| 273 | "@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n" |
| 274 | "signal handlers.") |
| 275 | #define FUNC_NAME s_scm_system_async_mark_for_thread |
| 276 | { |
| 277 | /* The current thread might not have a handle yet. This can happen |
| 278 | when the GC runs immediately before allocating the handle. At |
| 279 | the end of that GC, a system async might be marked. Thus, we can |
| 280 | not use scm_current_thread here. |
| 281 | */ |
| 282 | |
| 283 | scm_i_thread *t; |
| 284 | |
| 285 | if (SCM_UNBNDP (thread)) |
| 286 | t = SCM_I_CURRENT_THREAD; |
| 287 | else |
| 288 | { |
| 289 | SCM_VALIDATE_THREAD (2, thread); |
| 290 | if (scm_c_thread_exited_p (thread)) |
| 291 | SCM_MISC_ERROR ("thread has already exited", SCM_EOL); |
| 292 | t = SCM_I_THREAD_DATA (thread); |
| 293 | } |
| 294 | scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t); |
| 295 | return SCM_UNSPECIFIED; |
| 296 | } |
| 297 | #undef FUNC_NAME |
| 298 | |
| 299 | SCM |
| 300 | scm_system_async_mark (SCM proc) |
| 301 | #define FUNC_NAME s_scm_system_async_mark_for_thread |
| 302 | { |
| 303 | return scm_system_async_mark_for_thread (proc, SCM_UNDEFINED); |
| 304 | } |
| 305 | #undef FUNC_NAME |
| 306 | |
| 307 | \f |
| 308 | |
| 309 | |
| 310 | SCM_DEFINE (scm_noop, "noop", 0, 0, 1, |
| 311 | (SCM args), |
| 312 | "Do nothing. When called without arguments, return @code{#f},\n" |
| 313 | "otherwise return the first argument.") |
| 314 | #define FUNC_NAME s_scm_noop |
| 315 | { |
| 316 | SCM_VALIDATE_REST_ARGUMENT (args); |
| 317 | return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args)); |
| 318 | } |
| 319 | #undef FUNC_NAME |
| 320 | |
| 321 | |
| 322 | \f |
| 323 | |
| 324 | static void |
| 325 | increase_block (void *data) |
| 326 | { |
| 327 | scm_i_thread *t = data; |
| 328 | t->block_asyncs++; |
| 329 | } |
| 330 | |
| 331 | static void |
| 332 | decrease_block (void *data) |
| 333 | { |
| 334 | scm_i_thread *t = data; |
| 335 | if (--t->block_asyncs == 0) |
| 336 | scm_async_tick (); |
| 337 | } |
| 338 | |
| 339 | void |
| 340 | scm_dynwind_block_asyncs (void) |
| 341 | { |
| 342 | scm_i_thread *t = SCM_I_CURRENT_THREAD; |
| 343 | scm_dynwind_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY); |
| 344 | scm_dynwind_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY); |
| 345 | } |
| 346 | |
| 347 | void |
| 348 | scm_dynwind_unblock_asyncs (void) |
| 349 | { |
| 350 | scm_i_thread *t = SCM_I_CURRENT_THREAD; |
| 351 | if (t->block_asyncs == 0) |
| 352 | scm_misc_error ("scm_with_unblocked_asyncs", |
| 353 | "asyncs already unblocked", SCM_EOL); |
| 354 | scm_dynwind_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY); |
| 355 | scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY); |
| 356 | } |
| 357 | |
| 358 | SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0, |
| 359 | (SCM proc), |
| 360 | "Call @var{proc} with no arguments and block the execution\n" |
| 361 | "of system asyncs by one level for the current thread while\n" |
| 362 | "it is running. Return the value returned by @var{proc}.\n") |
| 363 | #define FUNC_NAME s_scm_call_with_blocked_asyncs |
| 364 | { |
| 365 | SCM ans; |
| 366 | |
| 367 | scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); |
| 368 | scm_dynwind_block_asyncs (); |
| 369 | ans = scm_call_0 (proc); |
| 370 | scm_dynwind_end (); |
| 371 | |
| 372 | return ans; |
| 373 | } |
| 374 | #undef FUNC_NAME |
| 375 | |
| 376 | void * |
| 377 | scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data) |
| 378 | { |
| 379 | void* ans; |
| 380 | |
| 381 | scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); |
| 382 | scm_dynwind_block_asyncs (); |
| 383 | ans = proc (data); |
| 384 | scm_dynwind_end (); |
| 385 | |
| 386 | return ans; |
| 387 | } |
| 388 | |
| 389 | |
| 390 | SCM_DEFINE (scm_call_with_unblocked_asyncs, "call-with-unblocked-asyncs", 1, 0, 0, |
| 391 | (SCM proc), |
| 392 | "Call @var{proc} with no arguments and unblock the execution\n" |
| 393 | "of system asyncs by one level for the current thread while\n" |
| 394 | "it is running. Return the value returned by @var{proc}.\n") |
| 395 | #define FUNC_NAME s_scm_call_with_unblocked_asyncs |
| 396 | { |
| 397 | SCM ans; |
| 398 | |
| 399 | if (SCM_I_CURRENT_THREAD->block_asyncs == 0) |
| 400 | SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL); |
| 401 | |
| 402 | scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); |
| 403 | scm_dynwind_unblock_asyncs (); |
| 404 | ans = scm_call_0 (proc); |
| 405 | scm_dynwind_end (); |
| 406 | |
| 407 | return ans; |
| 408 | } |
| 409 | #undef FUNC_NAME |
| 410 | |
| 411 | void * |
| 412 | scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data) |
| 413 | { |
| 414 | void* ans; |
| 415 | |
| 416 | if (SCM_I_CURRENT_THREAD->block_asyncs == 0) |
| 417 | scm_misc_error ("scm_c_call_with_unblocked_asyncs", |
| 418 | "asyncs already unblocked", SCM_EOL); |
| 419 | |
| 420 | scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); |
| 421 | scm_dynwind_unblock_asyncs (); |
| 422 | ans = proc (data); |
| 423 | scm_dynwind_end (); |
| 424 | |
| 425 | return ans; |
| 426 | } |
| 427 | |
| 428 | \f |
| 429 | /* These are function variants of the same-named macros (uppercase) for use |
| 430 | outside of libguile. This is so that `SCM_I_CURRENT_THREAD', which may |
| 431 | reside in TLS, is not accessed from outside of libguile. It thus allows |
| 432 | libguile to be built with the "local-dynamic" TLS model. */ |
| 433 | |
| 434 | void |
| 435 | scm_critical_section_start (void) |
| 436 | { |
| 437 | SCM_CRITICAL_SECTION_START; |
| 438 | } |
| 439 | |
| 440 | void |
| 441 | scm_critical_section_end (void) |
| 442 | { |
| 443 | SCM_CRITICAL_SECTION_END; |
| 444 | } |
| 445 | |
| 446 | \f |
| 447 | |
| 448 | void |
| 449 | scm_init_async () |
| 450 | { |
| 451 | tc16_async = scm_make_smob_type ("async", 0); |
| 452 | |
| 453 | #include "libguile/async.x" |
| 454 | } |
| 455 | |
| 456 | /* |
| 457 | Local Variables: |
| 458 | c-file-style: "gnu" |
| 459 | End: |
| 460 | */ |