libguile/async.c

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