libguile/async.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006 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
  18
  19 \f
  20 #if HAVE_CONFIG_H
  21 #  include <config.h>
  22 #endif
  23
  24 #include <signal.h>
  25 #include "libguile/_scm.h"
  26 #include "libguile/eval.h"
  27 #include "libguile/throw.h"
  28 #include "libguile/root.h"
  29 #include "libguile/smob.h"
  30 #include "libguile/lang.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 #ifdef HAVE_UNISTD_H
  41 #include <unistd.h>
  42 #endif
  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_CELL_WORD_0 (X) >> 16)
  86 #define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V) << 16)))
  87 #define ASYNC_THUNK(X)         SCM_CELL_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_click ()
 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 #if (SCM_ENABLE_DEPRECATED == 1)
 171
 172 SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
 173             (SCM thunk),
 174             "This function is deprecated.  You can use @var{thunk} directly\n"
 175             "instead of explicitely creating an async object.\n")
 176 #define FUNC_NAME s_scm_system_async
 177 {
 178   scm_c_issue_deprecation_warning
 179     ("'system-async' is deprecated.  "
 180      "Use the procedure directly with 'system-async-mark'.");
 181   return thunk;
 182 }
 183 #undef FUNC_NAME
 184
 185 #endif /* SCM_ENABLE_DEPRECATED == 1 */
 186
 187 void
 188 scm_i_queue_async_cell (SCM c, scm_i_thread *t)
 189 {
 190   SCM sleep_object;
 191   scm_i_pthread_mutex_t *sleep_mutex;
 192   int sleep_fd;
 193   SCM p;
 194
 195   scm_i_scm_pthread_mutex_lock (&async_mutex);
 196   p = t->active_asyncs;
 197   SCM_SETCDR (c, SCM_EOL);
 198   if (!scm_is_pair (p))
 199     t->active_asyncs = c;
 200   else
 201     {
 202       SCM pp;
 203       while (scm_is_pair (pp = SCM_CDR (p)))
 204         {
 205           if (scm_is_eq (SCM_CAR (p), SCM_CAR (c)))
 206             {
 207               scm_i_pthread_mutex_unlock (&async_mutex);
 208               return;
 209             }
 210           p = pp;
 211         }
 212       SCM_SETCDR (p, c);
 213     }
 214   t->pending_asyncs = 1;
 215   sleep_object = t->sleep_object;
 216   sleep_mutex = t->sleep_mutex;
 217   sleep_fd = t->sleep_fd;
 218   scm_i_pthread_mutex_unlock (&async_mutex);
 219
 220   if (sleep_mutex)
 221     {
 222       /* By now, the thread T might be out of its sleep already, or
 223          might even be in the next, unrelated sleep.  Interrupting it
 224          anyway does no harm, however.
 225
 226          The important thing to prevent here is to signal sleep_cond
 227          before T waits on it.  This can not happen since T has
 228          sleep_mutex locked while setting t->sleep_mutex and will only
 229          unlock it again while waiting on sleep_cond.
 230       */
 231       scm_i_scm_pthread_mutex_lock (sleep_mutex);
 232       scm_i_pthread_cond_signal (&t->sleep_cond);
 233       scm_i_pthread_mutex_unlock (sleep_mutex);
 234     }
 235
 236   if (sleep_fd >= 0)
 237     {
 238       char dummy = 0;
 239       /* Likewise, T might already been done with sleeping here, but
 240          interrupting it once too often does no harm.  T might also
 241          not yet have started sleeping, but this is no problem either
 242          since the data written to a pipe will not be lost, unlike a
 243          condition variable signal.
 244       */
 245       write (sleep_fd, &dummy, 1);
 246     }
 247
 248   /* This is needed to protect sleep_mutex.
 249    */
 250   scm_remember_upto_here_1 (sleep_object);
 251 }
 252
 253 int
 254 scm_i_setup_sleep (scm_i_thread *t,
 255                    SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex,
 256                    int sleep_fd)
 257 {
 258   int pending;
 259
 260   scm_i_scm_pthread_mutex_lock (&async_mutex);
 261   pending = t->pending_asyncs;
 262   if (!pending)
 263     {
 264       t->sleep_object = sleep_object;
 265       t->sleep_mutex = sleep_mutex;
 266       t->sleep_fd = sleep_fd;
 267     }
 268   scm_i_pthread_mutex_unlock (&async_mutex);
 269   return pending;
 270 }
 271
 272 void
 273 scm_i_reset_sleep (scm_i_thread *t)
 274 {
 275   scm_i_scm_pthread_mutex_lock (&async_mutex);
 276   t->sleep_object = SCM_BOOL_F;
 277   t->sleep_mutex = NULL;
 278   t->sleep_fd = -1;
 279   scm_i_pthread_mutex_unlock (&async_mutex);
 280 }
 281
 282 SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0,
 283            (SCM proc, SCM thread),
 284             "Mark @var{proc} (a procedure with zero arguments) for future execution\n"
 285             "in @var{thread}.  If @var{proc} has already been marked for\n"
 286             "@var{thread} but has not been executed yet, this call has no effect.\n"
 287             "If @var{thread} is omitted, the thread that called\n"
 288             "@code{system-async-mark} is used.\n\n"
 289             "This procedure is not safe to be called from C signal handlers.  Use\n"
 290             "@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n"
 291             "signal handlers.")
 292 #define FUNC_NAME s_scm_system_async_mark_for_thread
 293 {
 294   /* The current thread might not have a handle yet.  This can happen
 295      when the GC runs immediately before allocating the handle.  At
 296      the end of that GC, a system async might be marked.  Thus, we can
 297      not use scm_current_thread here.
 298   */
 299
 300   scm_i_thread *t;
 301
 302   if (SCM_UNBNDP (thread))
 303     t = SCM_I_CURRENT_THREAD;
 304   else
 305     {
 306       SCM_VALIDATE_THREAD (2, thread);
 307       if (scm_c_thread_exited_p (thread))
 308         SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
 309       t = SCM_I_THREAD_DATA (thread);
 310     }
 311   scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t);
 312   return SCM_UNSPECIFIED;
 313 }
 314 #undef FUNC_NAME
 315
 316 SCM
 317 scm_system_async_mark (SCM proc)
 318 #define FUNC_NAME s_scm_system_async_mark_for_thread
 319 {
 320   return scm_system_async_mark_for_thread (proc, SCM_UNDEFINED);
 321 }
 322 #undef FUNC_NAME
 323
 324 \f
 325
 326
 327 SCM_DEFINE (scm_noop, "noop", 0, 0, 1,
 328             (SCM args),
 329             "Do nothing.  When called without arguments, return @code{#f},\n"
 330             "otherwise return the first argument.")
 331 #define FUNC_NAME s_scm_noop
 332 {
 333   SCM_VALIDATE_REST_ARGUMENT (args);
 334   return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args));
 335 }
 336 #undef FUNC_NAME
 337
 338
 339 \f
 340
 341 #if (SCM_ENABLE_DEPRECATED == 1)
 342
 343 SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0,
 344             (),
 345             "Unmask signals. The returned value is not specified.")
 346 #define FUNC_NAME s_scm_unmask_signals
 347 {
 348   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 349
 350   scm_c_issue_deprecation_warning
 351     ("'unmask-signals' is deprecated.  "
 352      "Use 'call-with-blocked-asyncs' instead.");
 353
 354   if (t->block_asyncs == 0)
 355     SCM_MISC_ERROR ("signals already unmasked", SCM_EOL);
 356   t->block_asyncs = 0;
 357   scm_async_click ();
 358   return SCM_UNSPECIFIED;
 359 }
 360 #undef FUNC_NAME
 361
 362
 363 SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
 364             (),
 365             "Mask signals. The returned value is not specified.")
 366 #define FUNC_NAME s_scm_mask_signals
 367 {
 368   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 369
 370   scm_c_issue_deprecation_warning
 371     ("'mask-signals' is deprecated.  Use 'call-with-blocked-asyncs' instead.");
 372
 373   if (t->block_asyncs > 0)
 374     SCM_MISC_ERROR ("signals already masked", SCM_EOL);
 375   t->block_asyncs = 1;
 376   return SCM_UNSPECIFIED;
 377 }
 378 #undef FUNC_NAME
 379
 380 #endif /* SCM_ENABLE_DEPRECATED == 1 */
 381
 382 static void
 383 increase_block (void *data)
 384 {
 385   ((scm_i_thread *)data)->block_asyncs++;
 386 }
 387
 388 static void
 389 decrease_block (void *data)
 390 {
 391   if (--((scm_i_thread *)data)->block_asyncs == 0)
 392     scm_async_click ();
 393 }
 394
 395 SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
 396             (SCM proc),
 397             "Call @var{proc} with no arguments and block the execution\n"
 398             "of system asyncs by one level for the current thread while\n"
 399             "it is running.  Return the value returned by @var{proc}.\n")
 400 #define FUNC_NAME s_scm_call_with_blocked_asyncs
 401 {
 402   return scm_internal_dynamic_wind (increase_block,
 403                                     (scm_t_inner) scm_call_0,
 404                                     decrease_block,
 405                                     (void *)proc,
 406                                     SCM_I_CURRENT_THREAD);
 407 }
 408 #undef FUNC_NAME
 409
 410 void *
 411 scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data)
 412 {
 413   return (void *)scm_internal_dynamic_wind (increase_block,
 414                                             (scm_t_inner) proc,
 415                                             decrease_block,
 416                                             data,
 417                                             SCM_I_CURRENT_THREAD);
 418 }
 419
 420
 421 SCM_DEFINE (scm_call_with_unblocked_asyncs, "call-with-unblocked-asyncs", 1, 0, 0,
 422             (SCM proc),
 423             "Call @var{proc} with no arguments and unblock the execution\n"
 424             "of system asyncs by one level for the current thread while\n"
 425             "it is running.  Return the value returned by @var{proc}.\n")
 426 #define FUNC_NAME s_scm_call_with_unblocked_asyncs
 427 {
 428   if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
 429     SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL);
 430   return scm_internal_dynamic_wind (decrease_block,
 431                                     (scm_t_inner) scm_call_0,
 432                                     increase_block,
 433                                     (void *)proc,
 434                                     SCM_I_CURRENT_THREAD);
 435 }
 436 #undef FUNC_NAME
 437
 438 void *
 439 scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
 440 {
 441   if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
 442     scm_misc_error ("scm_c_call_with_unblocked_asyncs",
 443                     "asyncs already unblocked", SCM_EOL);
 444   return (void *)scm_internal_dynamic_wind (decrease_block,
 445                                             (scm_t_inner) proc,
 446                                             increase_block,
 447                                             data,
 448                                             SCM_I_CURRENT_THREAD);
 449 }
 450
 451 void
 452 scm_dynwind_block_asyncs ()
 453 {
 454   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 455   scm_dynwind_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
 456   scm_dynwind_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
 457 }
 458
 459 void
 460 scm_dynwind_unblock_asyncs ()
 461 {
 462   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 463   if (t->block_asyncs == 0)
 464     scm_misc_error ("scm_with_unblocked_asyncs",
 465                     "asyncs already unblocked", SCM_EOL);
 466   scm_dynwind_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
 467   scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
 468 }
 469
 470
 471 \f
 472
 473 void
 474 scm_init_async ()
 475 {
 476   scm_asyncs = SCM_EOL;
 477   tc16_async = scm_make_smob_type ("async", 0);
 478
 479 #include "libguile/async.x"
 480 }
 481
 482 /*
 483   Local Variables:
 484   c-file-style: "gnu"
 485   End:
 486 */