libguile/async.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004 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 static SCM
  90 async_gc_mark (SCM obj)
  91 {
  92   return ASYNC_THUNK (obj);
  93 }
  94
  95 SCM_DEFINE (scm_async, "async", 1, 0, 0,
  96             (SCM thunk),
  97             "Create a new async for the procedure @var{thunk}.")
  98 #define FUNC_NAME s_scm_async
  99 {
 100   SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk));
 101 }
 102 #undef FUNC_NAME
 103
 104 SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0,
 105             (SCM a),
 106             "Mark the async @var{a} for future execution.")
 107 #define FUNC_NAME s_scm_async_mark
 108 {
 109   VALIDATE_ASYNC (1, a);
 110   SET_ASYNC_GOT_IT (a, 1);
 111   return SCM_UNSPECIFIED;
 112 }
 113 #undef FUNC_NAME
 114
 115 SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0,
 116             (SCM list_of_a),
 117             "Execute all thunks from the asyncs of the list @var{list_of_a}.")
 118 #define FUNC_NAME s_scm_run_asyncs
 119 {
 120   while (! SCM_NULL_OR_NIL_P (list_of_a))
 121     {
 122       SCM a;
 123       SCM_VALIDATE_CONS (1, list_of_a);
 124       a = SCM_CAR (list_of_a);
 125       VALIDATE_ASYNC (SCM_ARG1, a);
 126       if (ASYNC_GOT_IT (a))
 127         {
 128           SET_ASYNC_GOT_IT (a, 0);
 129           scm_call_0 (ASYNC_THUNK (a));
 130         }
 131       list_of_a = SCM_CDR (list_of_a);
 132     }
 133   return SCM_BOOL_T;
 134 }
 135 #undef FUNC_NAME
 136
 137 \f
 138
 139 static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 140
 141 /* System asyncs. */
 142
 143 void
 144 scm_async_click ()
 145 {
 146   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 147   SCM asyncs;
 148
 149   /* Reset pending_asyncs even when asyncs are blocked and not really
 150      executed since this will avoid future futile calls to this
 151      function.  When asyncs are unblocked again, this function is
 152      invoked even when pending_asyncs is zero.
 153   */
 154
 155   scm_i_scm_pthread_mutex_lock (&async_mutex);
 156   t->pending_asyncs = 0;
 157   if (t->block_asyncs == 0)
 158     {
 159       asyncs = t->active_asyncs;
 160       t->active_asyncs = SCM_EOL;
 161     }
 162   else
 163     asyncs = SCM_EOL;
 164   scm_i_pthread_mutex_unlock (&async_mutex);
 165
 166   while (scm_is_pair (asyncs))
 167     {
 168       SCM next = SCM_CDR (asyncs);
 169       SCM_SETCDR (asyncs, SCM_BOOL_F);
 170       scm_call_0 (SCM_CAR (asyncs));
 171       asyncs = next;
 172     }
 173 }
 174
 175 #if (SCM_ENABLE_DEPRECATED == 1)
 176
 177 SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
 178             (SCM thunk),
 179             "This function is deprecated.  You can use @var{thunk} directly\n"
 180             "instead of explicitely creating an async object.\n")
 181 #define FUNC_NAME s_scm_system_async
 182 {
 183   scm_c_issue_deprecation_warning
 184     ("'system-async' is deprecated.  "
 185      "Use the procedure directly with 'system-async-mark'.");
 186   return thunk;
 187 }
 188 #undef FUNC_NAME
 189
 190 #endif /* SCM_ENABLE_DEPRECATED == 1 */
 191
 192 void
 193 scm_i_queue_async_cell (SCM c, scm_i_thread *t)
 194 {
 195   SCM sleep_object;
 196   scm_i_pthread_mutex_t *sleep_mutex;
 197   int sleep_fd;
 198   SCM p;
 199
 200   scm_i_scm_pthread_mutex_lock (&async_mutex);
 201   p = t->active_asyncs;
 202   SCM_SETCDR (c, SCM_EOL);
 203   if (!scm_is_pair (p))
 204     t->active_asyncs = c;
 205   else
 206     {
 207       SCM pp;
 208       while (scm_is_pair (pp = SCM_CDR (p)))
 209         {
 210           if (scm_is_eq (SCM_CAR (p), SCM_CAR (c)))
 211             {
 212               scm_i_pthread_mutex_unlock (&async_mutex);
 213               return;
 214             }
 215           p = pp;
 216         }
 217       SCM_SETCDR (p, c);
 218     }
 219   t->pending_asyncs = 1;
 220   sleep_object = t->sleep_object;
 221   sleep_mutex = t->sleep_mutex;
 222   sleep_fd = t->sleep_fd;
 223   scm_i_pthread_mutex_unlock (&async_mutex);
 224
 225   if (sleep_mutex)
 226     {
 227       /* By now, the thread T might be out of its sleep already, or
 228          might even be in the next, unrelated sleep.  Interrupting it
 229          anyway does no harm, however.
 230
 231          The important thing to prevent here is to signal sleep_cond
 232          before T waits on it.  This can not happen since T has
 233          sleep_mutex locked while setting t->sleep_mutex and will only
 234          unlock it again while waiting on sleep_cond.
 235       */
 236       scm_i_scm_pthread_mutex_lock (sleep_mutex);
 237       scm_i_pthread_cond_signal (&t->sleep_cond);
 238       scm_i_pthread_mutex_unlock (sleep_mutex);
 239     }
 240
 241   if (sleep_fd >= 0)
 242     {
 243       char dummy = 0;
 244       /* Likewise, T might already been done with sleeping here, but
 245          interrupting it once too often does no harm.  T might also
 246          not yet have started sleeping, but this is no problem either
 247          since the data written to a pipe will not be lost, unlike a
 248          condition variable signal.
 249       */
 250       write (sleep_fd, &dummy, 1);
 251     }
 252
 253   /* This is needed to protect sleep_mutex.
 254    */
 255   scm_remember_upto_here_1 (sleep_object);
 256 }
 257
 258 int
 259 scm_i_setup_sleep (scm_i_thread *t,
 260                    SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex,
 261                    int sleep_fd)
 262 {
 263   int pending;
 264
 265   scm_i_scm_pthread_mutex_lock (&async_mutex);
 266   pending = t->pending_asyncs;
 267   if (!pending)
 268     {
 269       t->sleep_object = sleep_object;
 270       t->sleep_mutex = sleep_mutex;
 271       t->sleep_fd = sleep_fd;
 272     }
 273   scm_i_pthread_mutex_unlock (&async_mutex);
 274   return pending;
 275 }
 276
 277 void
 278 scm_i_reset_sleep (scm_i_thread *t)
 279 {
 280   scm_i_scm_pthread_mutex_lock (&async_mutex);
 281   t->sleep_object = SCM_BOOL_F;
 282   t->sleep_mutex = NULL;
 283   t->sleep_fd = -1;
 284   scm_i_pthread_mutex_unlock (&async_mutex);
 285 }
 286
 287 SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0,
 288            (SCM proc, SCM thread),
 289             "Mark @var{proc} (a procedure with zero arguments) for future execution\n"
 290             "in @var{thread}.  If @var{proc} has already been marked for\n"
 291             "@var{thread} but has not been executed yet, this call has no effect.\n"
 292             "If @var{thread} is omitted, the thread that called\n"
 293             "@code{system-async-mark} is used.\n\n"
 294             "This procedure is not safe to be called from C signal handlers.  Use\n"
 295             "@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n"
 296             "signal handlers.")
 297 #define FUNC_NAME s_scm_system_async_mark_for_thread
 298 {
 299   /* The current thread might not have a handle yet.  This can happen
 300      when the GC runs immediately before allocating the handle.  At
 301      the end of that GC, a system async might be marked.  Thus, we can
 302      not use scm_current_thread here.
 303   */
 304
 305   scm_i_thread *t;
 306
 307   if (SCM_UNBNDP (thread))
 308     t = SCM_I_CURRENT_THREAD;
 309   else
 310     {
 311       SCM_VALIDATE_THREAD (2, thread);
 312       if (scm_c_thread_exited_p (thread))
 313         SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
 314       t = SCM_I_THREAD_DATA (thread);
 315     }
 316   scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t);
 317   return SCM_UNSPECIFIED;
 318 }
 319 #undef FUNC_NAME
 320
 321 SCM
 322 scm_system_async_mark (SCM proc)
 323 #define FUNC_NAME s_scm_system_async_mark_for_thread
 324 {
 325   return scm_system_async_mark_for_thread (proc, SCM_UNDEFINED);
 326 }
 327 #undef FUNC_NAME
 328
 329 \f
 330
 331
 332 SCM_DEFINE (scm_noop, "noop", 0, 0, 1,
 333             (SCM args),
 334             "Do nothing.  When called without arguments, return @code{#f},\n"
 335             "otherwise return the first argument.")
 336 #define FUNC_NAME s_scm_noop
 337 {
 338   SCM_VALIDATE_REST_ARGUMENT (args);
 339   return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args));
 340 }
 341 #undef FUNC_NAME
 342
 343
 344 \f
 345
 346 #if (SCM_ENABLE_DEPRECATED == 1)
 347
 348 SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0,
 349             (),
 350             "Unmask signals. The returned value is not specified.")
 351 #define FUNC_NAME s_scm_unmask_signals
 352 {
 353   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 354
 355   scm_c_issue_deprecation_warning
 356     ("'unmask-signals' is deprecated.  "
 357      "Use 'call-with-blocked-asyncs' instead.");
 358
 359   if (t->block_asyncs == 0)
 360     SCM_MISC_ERROR ("signals already unmasked", SCM_EOL);
 361   t->block_asyncs = 0;
 362   scm_async_click ();
 363   return SCM_UNSPECIFIED;
 364 }
 365 #undef FUNC_NAME
 366
 367
 368 SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
 369             (),
 370             "Mask signals. The returned value is not specified.")
 371 #define FUNC_NAME s_scm_mask_signals
 372 {
 373   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 374
 375   scm_c_issue_deprecation_warning
 376     ("'mask-signals' is deprecated.  Use 'call-with-blocked-asyncs' instead.");
 377
 378   if (t->block_asyncs > 0)
 379     SCM_MISC_ERROR ("signals already masked", SCM_EOL);
 380   t->block_asyncs = 1;
 381   return SCM_UNSPECIFIED;
 382 }
 383 #undef FUNC_NAME
 384
 385 #endif /* SCM_ENABLE_DEPRECATED == 1 */
 386
 387 static void
 388 increase_block (void *data)
 389 {
 390   ((scm_i_thread *)data)->block_asyncs++;
 391 }
 392
 393 static void
 394 decrease_block (void *data)
 395 {
 396   if (--((scm_i_thread *)data)->block_asyncs == 0)
 397     scm_async_click ();
 398 }
 399
 400 SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
 401             (SCM proc),
 402             "Call @var{proc} with no arguments and block the execution\n"
 403             "of system asyncs by one level for the current thread while\n"
 404             "it is running.  Return the value returned by @var{proc}.\n")
 405 #define FUNC_NAME s_scm_call_with_blocked_asyncs
 406 {
 407   return scm_internal_dynamic_wind (increase_block,
 408                                     (scm_t_inner) scm_call_0,
 409                                     decrease_block,
 410                                     (void *)proc,
 411                                     SCM_I_CURRENT_THREAD);
 412 }
 413 #undef FUNC_NAME
 414
 415 void *
 416 scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data)
 417 {
 418   return (void *)scm_internal_dynamic_wind (increase_block,
 419                                             (scm_t_inner) proc,
 420                                             decrease_block,
 421                                             data,
 422                                             SCM_I_CURRENT_THREAD);
 423 }
 424
 425
 426 SCM_DEFINE (scm_call_with_unblocked_asyncs, "call-with-unblocked-asyncs", 1, 0, 0,
 427             (SCM proc),
 428             "Call @var{proc} with no arguments and unblock the execution\n"
 429             "of system asyncs by one level for the current thread while\n"
 430             "it is running.  Return the value returned by @var{proc}.\n")
 431 #define FUNC_NAME s_scm_call_with_unblocked_asyncs
 432 {
 433   if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
 434     SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL);
 435   return scm_internal_dynamic_wind (decrease_block,
 436                                     (scm_t_inner) scm_call_0,
 437                                     increase_block,
 438                                     (void *)proc,
 439                                     SCM_I_CURRENT_THREAD);
 440 }
 441 #undef FUNC_NAME
 442
 443 void *
 444 scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
 445 {
 446   if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
 447     scm_misc_error ("scm_c_call_with_unblocked_asyncs",
 448                     "asyncs already unblocked", SCM_EOL);
 449   return (void *)scm_internal_dynamic_wind (decrease_block,
 450                                             (scm_t_inner) proc,
 451                                             increase_block,
 452                                             data,
 453                                             SCM_I_CURRENT_THREAD);
 454 }
 455
 456 void
 457 scm_dynwind_block_asyncs ()
 458 {
 459   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 460   scm_dynwind_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
 461   scm_dynwind_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
 462 }
 463
 464 void
 465 scm_dynwind_unblock_asyncs ()
 466 {
 467   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 468   if (t->block_asyncs == 0)
 469     scm_misc_error ("scm_with_unblocked_asyncs",
 470                     "asyncs already unblocked", SCM_EOL);
 471   scm_dynwind_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
 472   scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
 473 }
 474
 475
 476 \f
 477
 478 void
 479 scm_init_async ()
 480 {
 481   scm_asyncs = SCM_EOL;
 482   tc16_async = scm_make_smob_type ("async", 0);
 483   scm_set_smob_mark (tc16_async, async_gc_mark);
 484
 485 #include "libguile/async.x"
 486 }
 487
 488 /*
 489   Local Variables:
 490   c-file-style: "gnu"
 491   End:
 492 */