libguile/async.c

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