libguile/async.c

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