async.c 13 KB

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